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.8 2004/12/04 18:41:31 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 "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
 463 ;; File chooser dialog
 464
 465 (define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
 466   (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
 467   (dialog-add-button dialog "gtk-ok"
 468    #'(lambda ()
 469        (format t "Selected file: ~A~%" (file-chooser-filename dialog))
 470        (widget-destroy dialog))))
 471
 472
 473
 474 ;;; Handle box
 475
 476 ;; (defun create-handle-box-toolbar ()
 477 ;;   (let ((toolbar (toolbar-new :horizontal :both)))
 478 ;;     (toolbar-append-item
 479 ;;      toolbar "Horizontal" (pixmap-new "clg:examples;test.xpm")
 480 ;;      :tooltip-text "Horizontal toolbar layout"
 481 ;;      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
 482
 483 ;;     (toolbar-append-item
 484 ;;      toolbar "Vertical" (pixmap-new "clg:examples;test.xpm")
 485 ;;      :tooltip-text "Vertical toolbar layout"
 486 ;;      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
 487
 488 ;;     (toolbar-append-space toolbar)
 489
 490 ;;     (toolbar-append-item
 491 ;;      toolbar "Icons" (pixmap-new "clg:examples;test.xpm")
 492 ;;      :tooltip-text "Only show toolbar icons"
 493 ;;      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
 494
 495 ;;     (toolbar-append-item
 496 ;;      toolbar "Text" (pixmap-new "clg:examples;test.xpm")
 497 ;;      :tooltip-text "Only show toolbar text"
 498 ;;      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
 499
 500 ;;     (toolbar-append-item
 501 ;;      toolbar "Both" (pixmap-new "clg:examples;test.xpm")
 502 ;;      :tooltip-text "Show toolbar icons and text"
 503 ;;      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
 504
 505 ;;     (toolbar-append-space toolbar)
 506
 507 ;;     (toolbar-append-item
 508 ;;      toolbar "Small" (pixmap-new "clg:examples;test.xpm")
 509 ;;      :tooltip-text "Use small spaces"
 510 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
 511
 512 ;;     (toolbar-append-item
 513 ;;      toolbar "Big" (pixmap-new "clg:examples;test.xpm")
 514 ;;      :tooltip-text "Use big spaces"
 515 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
 516
 517 ;;     (toolbar-append-space toolbar)
 518
 519 ;;     (toolbar-append-item
 520 ;;      toolbar "Enable" (pixmap-new "clg:examples;test.xpm")
 521 ;;      :tooltip-text "Enable tooltips"
 522 ;;      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
 523
 524 ;;     (toolbar-append-item
 525 ;;      toolbar "Disable" (pixmap-new "clg:examples;test.xpm")
 526 ;;      :tooltip-text "Disable tooltips"
 527 ;;      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
 528
 529 ;;     (toolbar-append-space toolbar)
 530
 531 ;;     (toolbar-append-item
 532 ;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
 533 ;;      :tooltip-text "Show borders"
 534 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
 535
 536 ;;     (toolbar-append-item
 537 ;;      toolbar "Borderless" (pixmap-new "clg:examples;test.xpm")
 538 ;;      :tooltip-text "Hide borders"
 539 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
 540
 541 ;;     toolbar))
 542
 543
 544 ;; (defun handle-box-child-signal (handle-box child action)
 545 ;;   (format t "~S: child ~S ~A~%" handle-box child action))
 546
 547
 548 ;; (define-test-window create-handle-box "Handle Box Test"
 549 ;;   (setf (window-allow-grow-p window) t)
 550 ;;   (setf (window-allow-shrink-p window) t)
 551 ;;   (setf (window-auto-shrink-p window) nil)
 552 ;;   (setf (container-border-width window) 20)
 553 ;;   (let ((v-box (v-box-new nil 0)))
 554 ;;     (container-add window v-box)
 555
 556 ;;     (container-add v-box (create-label "Above"))
 557 ;;     (container-add v-box (hseparator-new))
 558
 559 ;;     (let ((hbox (hbox-new nil 10)))
 560 ;;       (container-add v-box hbox)
 561
 562 ;;       (let ((handle-box (handle-box-new)))
 563 ;;      (box-pack-start hbox handle-box nil nil 0)
 564 ;;      (signal-connect
 565 ;;       handle-box 'child-attached
 566 ;;       #'(lambda (child)
 567 ;;           (handle-box-child-signal handle-box child "attached")))
 568 ;;      (signal-connect
 569 ;;       handle-box 'child-detached
 570 ;;       #'(lambda (child)
 571 ;;           (handle-box-child-signal handle-box child "detached")))
 572 ;;      (container-add handle-box (create-handle-box-toolbar)))
 573
 574 ;;       (let ((handle-box (handle-box-new)))
 575 ;;      (box-pack-start hbox handle-box nil nil 0)
 576 ;;      (signal-connect
 577 ;;       handle-box 'child-attached
 578 ;;       #'(lambda (child)
 579 ;;           (handle-box-child-signal handle-box child "attached")))
 580 ;;      (signal-connect
 581 ;;       handle-box 'child-detached
 582 ;;       #'(lambda (child)
 583 ;;           (handle-box-child-signal handle-box child "detached")))
 584
 585 ;;      (let ((handle-box2 (handle-box-new)))
 586 ;;        (container-add handle-box handle-box2)
 587 ;;        (signal-connect
 588 ;;         handle-box2 'child-attached
 589 ;;         #'(lambda (child)
 590 ;;             (handle-box-child-signal handle-box child "attached")))
 591 ;;        (signal-connect
 592 ;;         handle-box2 'child-detached
 593 ;;         #'(lambda (child)
 594 ;;             (handle-box-child-signal handle-box child "detached")))
 595 ;;        (container-add handle-box2 (create-label "Foo!")))))
 596
 597 ;;     (container-add v-box (hseparator-new))
 598 ;;     (container-add v-box (create-label "Below"))))
 599
 600 ;;; Image
 601
 602 (define-toplevel create-image (window "Image")
 603   (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
 604
 605
 606 ;;; Labels
 607
 608 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 609   (flet ((create-label-in-frame (frame-label label-text &rest args)
 610            (list
 611             (make-instance 'frame
 612              :label frame-label
 613              :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
 614             :fill nil :expand nil)))
 615     (make-instance 'h-box
 616      :spacing 5 :parent window
 617      :child-args '(:fill nil :expand nil)
 618      :child (make-instance 'v-box
 619              :spacing 5
 620              :child (create-label-in-frame "Normal Label" "This is a Normal label")
 621              :child (create-label-in-frame "Multi-line Label"
 622 "This is a Multi-line label.
 623 Second line
 624 Third line")
 625              :child (create-label-in-frame "Left Justified Label"
 626 "This is a Left-Justified
 627 Multi-line.
 628 Third line"
 629                       :justify :left)
 630              :child (create-label-in-frame "Right Justified Label"
 631 "This is a Right-Justified
 632 Multi-line.
 633 Third line"
 634                      :justify :right))
 635      :child (make-instance 'v-box
 636              :spacing 5
 637              :child (create-label-in-frame "Line wrapped label"
 638 "This is an example of a line-wrapped label.  It should not be taking up the entire             width allocated to it, but automatically wraps the words to fit.  The time has come, for all good men, to come to the aid of their party.  The sixth sheik's six sheep's sick.
 639      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
 640                       :wrap t)
 641
 642              :child (create-label-in-frame "Filled, wrapped label"
 643 "This is an example of a line-wrapped, filled label.  It should be taking up the entire              width allocated to it.  Here is a seneance to prove my point.  Here is another sentence. Here comes the sun, do de do de do.
 644     This is a new paragraph.
 645     This is another newer, longer, better paragraph.  It is coming to an end, unfortunately."
 646                       :justify :fill :wrap t)
 647
 648              :child (create-label-in-frame "Underlined label"
 649 "This label is underlined!
 650 This one is underlined (こんにちは) in quite a funky fashion"
 651                       :justify :left
 652                       :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 653
 654
 655 ;;; Layout
 656
 657 ;; (defun layout-expose (layout event)
 658 ;;   (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-simple-dialog create-list (dialog "List" :default-height 400)
 717   (let* ((store (make-instance 'list-store
 718                  :column-types '(string int boolean)
 719                  :column-names '(:foo :bar :baz)
 720                  :initial-content '(#("First" 12321 nil)
 721                                     (:foo "Yeah" :baz t))))
 722          (tree (make-instance 'tree-view :model store)))
 723
 724     (loop
 725      with iter = (make-instance 'tree-iter)
 726      for i from 1 to 1000
 727      do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
 728
 729     (let ((column (make-instance 'tree-view-column :title "Column 1"))
 730           (cell (make-instance 'cell-renderer-text)))
 731       (cell-layout-pack column cell :expand t)
 732       (cell-layout-add-attribute column cell 'text (column-index store :foo))
 733       (tree-view-append-column tree column))
 734
 735     (let ((column (make-instance 'tree-view-column :title "Column 2"))
 736           (cell (make-instance 'cell-renderer-text :background "orange")))
 737       (cell-layout-pack column cell :expand t)
 738       (cell-layout-add-attribute column cell 'text (column-index store :bar))
 739       (tree-view-append-column tree column))
 740
 741     (let ((column (make-instance 'tree-view-column :title "Column 3"))
 742           (cell (make-instance 'cell-renderer-text)))
 743       (cell-layout-pack column cell :expand t)
 744       (cell-layout-add-attribute column cell 'text (column-index store :baz))
 745       (tree-view-append-column tree column))
 746
 747     (make-instance 'v-box
 748      :parent dialog :border-width 10 :spacing 10 :show-all t
 749      :child (list
 750              (make-instance 'h-box
 751               :spacing 10
 752               :child (make-instance 'button
 753                       :label "Remove Selection"
 754                       :signal (list 'clicked
 755                                #'(lambda ()
 756                                    (let ((references
 757                                           (mapcar
 758                                            #'(lambda (path)
 759                                                (make-instance 'tree-row-reference :model store :path path))
 760                                            (tree-selection-get-selected-rows
 761                                             (tree-view-selection tree)))))
 762                                      (mapc
 763                                       #'(lambda (reference)
 764                                           (list-store-remove store reference))
 765                                       references))))))
 766              :expand nil)
 767      :child (list
 768              (make-instance 'h-box
 769               :spacing 10
 770               :child (make-instance 'check-button
 771                       :label "Show Headers" :active t
 772                       :signal (list 'toggled
 773                                #'(lambda (button)
 774                                    (setf
 775                                     (tree-view-headers-visible-p tree)
 776                                     (toggle-button-active-p button)))
 777                                :object t))
 778               :child (make-instance 'check-button
 779                       :label "Reorderable" :active nil
 780                       :signal (list 'toggled
 781                                #'(lambda (button)
 782                                    (setf
 783                                     (tree-view-reorderable-p tree)
 784                                     (toggle-button-active-p button)))
 785                                :object t))
 786               :child (list
 787                       (make-instance 'h-box
 788                        :child (make-instance 'label :label "Selection Mode: ")
 789                        :child (make-instance 'combo-box
 790                                :content '("Single" "Browse" "Multiple")
 791                                :active 0
 792                                :signal (list 'changed
 793                                         #'(lambda (combo-box)
 794                                             (setf
 795                                              (tree-selection-mode
 796                                               (tree-view-selection tree))
 797                                              (svref
 798                                               #(:single :browse :multiple)
 799                                               (combo-box-active combo-box))))
 800                                         :object t)))
 801                       :expand nil))
 802              :expand nil)
 803      :child (make-instance 'scrolled-window
 804             :child tree :hscrollbar-policy :automatic))))
 805
 806
 807 ;; Menus
 808
 809 (defun create-menu (depth tearoff)
 810   (unless (zerop depth)
 811     (let ((menu (make-instance 'menu)))
 812       (when tearoff
 813         (let ((menu-item (make-instance 'tearoff-menu-item)))
 814           (menu-shell-append menu menu-item)))
 815       (let ((group nil))
 816         (dotimes (i 5)
 817           (let ((menu-item
 818                  (make-instance 'radio-menu-item
 819                   :label (format nil "item ~2D - ~D" depth (1+ i)))))
 820             (if group
 821                 (radio-menu-item-add-to-group menu-item group)
 822               (setq group menu-item))
 823             (unless (zerop (mod depth 2))
 824               (setf (check-menu-item-active-p menu-item) t))
 825             (menu-shell-append menu menu-item)
 826             (when (= i 3)
 827               (setf (widget-sensitive-p menu-item) nil))
 828             (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
 829       menu)))
 830
 831
 832 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 833   (let* ((main (make-instance 'v-box :parent dialog))
 834 ;        (accel-group (make-instance 'accel-group))
 835          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 836 ;    (accel-group-attach accel-group window)
 837
 838     (let ((menu-item (make-instance 'menu-item
 839                       :label (format nil "test~%line2"))))
 840       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 841       (menu-shell-append menubar menu-item))
 842
 843     (let ((menu-item (make-instance 'menu-item :label "foo")))
 844       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 845       (menu-shell-append menubar menu-item))
 846
 847     (let ((menu-item (make-instance 'menu-item :label "bar")))
 848       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 849       (setf (menu-item-right-justified-p menu-item) t)
 850       (menu-shell-append menubar menu-item))
 851
 852     (make-instance 'v-box
 853      :spacing 10 :border-width 10 :parent main
 854      :child (make-instance 'combo-box
 855              :active 3
 856              :content (loop
 857                        for i from 1 to 5
 858                        collect (format nil "Item ~D" i))))
 859
 860     (widget-show-all main)))
 861
 862
 863 ;;; Notebook
 864
 865 (defun create-notebook-page (notebook page-num)
 866   (let* ((title (format nil "Page ~D" page-num))
 867          (page (make-instance 'frame :label title :border-width 10))
 868          (v-box (make-instance 'v-box
 869                  :homogeneous t :border-width 10 :parent page)))
 870
 871     (make-instance 'h-box
 872      :parent (list v-box :fill nil :padding 5) :homogeneous t
 873      :child-args '(:padding 5)
 874      :child (make-instance 'check-button
 875              :label "Fill Tab" :active t
 876              :signal (list 'toggled
 877                            #'(lambda (button)
 878                                (setf
 879                                 (notebook-child-tab-fill-p page)
 880                                 (toggle-button-active-p button)))
 881                            :object t))
 882      :child (make-instance 'check-button
 883              :label "Expand Tab"
 884              :signal (list 'toggled
 885                            #'(lambda (button)
 886                                (setf
 887                                 (notebook-child-tab-expand-p page)
 888                                 (toggle-button-active-p button)))
 889                            :object t))
 890      :child (make-instance 'check-button
 891              :label "Pack end"
 892              :signal (list 'toggled
 893                            #'(lambda (button)
 894                                (setf
 895                                 (notebook-child-tab-pack page)
 896                                 (if (toggle-button-active-p button)
 897                                     :end
 898                                   :start)))
 899                            :object t))
 900      :child (make-instance 'button
 901              :label "Hide page"
 902              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 903
 904     (let ((label-box (make-instance 'h-box
 905                       :show-all t
 906                       :child-args '(:expand nil)
 907                       :child (make-instance 'image :pixmap book-closed-xpm)
 908                       :child (make-instance 'label :label title)))
 909           (menu-box (make-instance 'h-box
 910                      :show-all t
 911                      :child-args '(:expand nil)
 912                      :child (make-instance 'image :pixmap book-closed-xpm)
 913                      :child (make-instance 'label :label title))))
 914
 915       (widget-show-all page)
 916       (notebook-append notebook page label-box menu-box))))
 917
 918
 919 (define-simple-dialog create-notebook (dialog "Notebook")
 920   (let ((main (make-instance 'v-box :parent dialog)))
 921     (let ((notebook (make-instance 'notebook
 922                      :border-width 10 :tab-pos :top :parent main)))
 923       (flet ((set-image (page func xpm)
 924                (image-set-from-pixmap-data
 925                 (first (container-children (funcall func notebook page)))
 926                 xpm)))
 927         (signal-connect notebook 'switch-page
 928          #'(lambda (pointer page)
 929              (declare (ignore pointer))
 930              (unless (eq page (notebook-current-page-num notebook))
 931                (set-image page #'notebook-menu-label book-open-xpm)
 932                (set-image page #'notebook-tab-label book-open-xpm)
 933
 934                (let ((curpage (notebook-current-page notebook)))
 935                  (when curpage
 936                    (set-image curpage #'notebook-menu-label book-closed-xpm)
 937                    (set-image curpage #'notebook-tab-label book-closed-xpm)))))))
 938       (loop for i from 1 to 5 do (create-notebook-page notebook i))
 939
 940       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 941
 942       (make-instance 'h-box
 943        :spacing 5 :border-width 10
 944        :parent (list main :expand nil)
 945        :child-args '(:fill nil)
 946        :child (make-instance 'check-button
 947                :label "Popup menu"
 948                :signal (list 'clicked
 949                         #'(lambda (button)
 950                             (if (toggle-button-active-p button)
 951                                 (notebook-popup-enable notebook)
 952                                 (notebook-popup-disable notebook)))
 953                         :object t))
 954        :child (make-instance 'check-button
 955                :label "Homogeneous tabs"
 956                :signal (list 'clicked
 957                         #'(lambda (button)
 958                             (setf
 959                              (notebook-homogeneous-p notebook)
 960                              (toggle-button-active-p button)))
 961                         :object t)))
 962
 963       (make-instance 'h-box
 964        :spacing 5 :border-width 10
 965        :parent (list main :expand nil)
 966        :child-args '(:expand nil)
 967        :child (make-instance 'label :label "Notebook Style: ")
 968        :child (let ((scrollable-p nil))
 969                 ;; option menu is deprecated, we should use combo-box
 970                 (make-instance 'combo-box
 971                  :content '("Standard" "No tabs" "Scrollable") :active 0
 972                  :signal (list 'changed
 973                           #'(lambda (combo-box)
 974                               (case (combo-box-active combo-box)
 975                                 (0
 976                                  (setf (notebook-show-tabs-p notebook) t)
 977                                  (when scrollable-p
 978                                    (setq scrollable-p nil)
 979                                    (setf (notebook-scrollable-p notebook) nil)
 980                                    (loop repeat 10
 981                                     do (notebook-remove-page notebook 5))))
 982                                 (1
 983                                  (setf (notebook-show-tabs-p notebook) nil)
 984                                  (when scrollable-p
 985                                    (setq scrollable-p nil)
 986                                    (setf (notebook-scrollable-p notebook) nil)
 987                                    (loop repeat 10
 988                                      do (notebook-remove-page notebook 5))))
 989                                 (2
 990                                  (unless scrollable-p
 991                                    (setq scrollable-p t)
 992                                    (setf (notebook-show-tabs-p notebook) t)
 993                                    (setf (notebook-scrollable-p notebook) t)
 994                                    (loop for i from 6 to 15
 995                                     do (create-notebook-page notebook i))))))
 996                           :object t)))
 997        :child (make-instance 'button
 998                :label "Show all Pages"
 999                :signal (list 'clicked
1000                         #'(lambda ()
1001                             (map-container nil #'widget-show notebook)))))
1002
1003       (make-instance 'h-box
1004        :spacing 5 :border-width 10
1005        :parent (list main :expand nil)
1006        :child (make-instance 'button
1007                :label "prev"
1008                :signal (list 'clicked #'notebook-prev-page :object notebook))
1009        :child (make-instance 'button
1010                :label "next"
1011                :signal (list 'clicked #'notebook-next-page :object notebook))
1012        :child (make-instance 'button
1013                :label "rotate"
1014                :signal (let ((tab-pos 0))
1015                          (list 'clicked
1016                           #'(lambda ()
1017                               (setq tab-pos (mod (1+ tab-pos) 4))
1018                               (setf
1019                                (notebook-tab-pos notebook)
1020                                (svref #(:top :right :bottom :left) tab-pos))))))))
1021     (widget-show-all main)))
1022
1023
1024 ;;; Panes
1025
1026 (defun toggle-resize (child)
1027   (let* ((paned (widget-parent child))
1028          (is-child1-p (eq child (paned-child1 paned))))
1029     (multiple-value-bind (child resize shrink)
1030         (if is-child1-p
1031             (paned-child1 paned)
1032           (paned-child2 paned))
1033       (container-remove paned child)
1034       (if is-child1-p
1035           (paned-pack1 paned child (not resize) shrink)
1036         (paned-pack2 paned child (not resize) shrink)))))
1037
1038 (defun toggle-shrink (child)
1039   (let* ((paned (widget-parent child))
1040          (is-child1-p (eq child (paned-child1 paned))))
1041     (multiple-value-bind (child resize shrink)
1042         (if is-child1-p
1043             (paned-child1 paned)
1044           (paned-child2 paned))
1045       (container-remove paned child)
1046       (if is-child1-p
1047           (paned-pack1 paned child resize (not shrink))
1048         (paned-pack2 paned child resize (not shrink))))))
1049
1050 (defun create-pane-options (paned frame-label label1 label2)
1051   (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
1052          (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
1053                                       :parent frame)))
1054
1055     (table-attach table (create-label label1) 0 1 0 1)
1056     (let ((check-button (make-instance 'check-button :label "Resize")))
1057       (table-attach table check-button 0 1 1 2)
1058       (signal-connect
1059        check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
1060     (let ((check-button (make-instance 'check-button :label "Shrink")))
1061       (table-attach table check-button 0 1 2 3)
1062       (setf (toggle-button-active-p check-button) t)
1063       (signal-connect
1064        check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1065
1066     (table-attach table (create-label label2) 1 2 0 1)
1067     (let ((check-button (make-instance 'check-button :label "Resize")))
1068       (table-attach table check-button 1 2 1 2)
1069       (setf (toggle-button-active-p check-button) t)
1070       (signal-connect
1071        check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
1072     (let ((check-button (make-instance 'check-button :label "Shrink")))
1073       (table-attach table check-button 1 2 2 3)
1074       (setf (toggle-button-active-p check-button) t)
1075       (signal-connect
1076        check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
1077     frame))
1078
1079 (define-toplevel create-panes (window "Panes")
1080   (let* ((hpaned (make-instance 'h-paned
1081                   :child1 (make-instance 'frame
1082                            :width-request 60 :height-request 60
1083                            :shadow-type :in
1084                            :child (make-instance 'buttun :label "Hi there"))
1085                   :child2 (make-instance 'frame
1086                            :width-request 80 :height-request 60
1087                            :shadow-type :in)))
1088          (vpaned (make-instance 'v-paned
1089                   :border-width 5
1090                   :child1 hpaned
1091                   :child2 (make-instance 'frame
1092                            :width-request 80 :height-request 60
1093                            :shadow-type :in))))
1094
1095     (make-instance 'v-box
1096      :parent window
1097      :child-args '(:expand nil)
1098      :child (list vpaned :expand t)
1099      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1100      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1101
1102
1103 ;;; Progress bar
1104
1105
1106
1107
1108 ;;; Radio buttons
1109
1110 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1111   (make-instance 'v-box
1112    :parent dialog :border-width 10 :spacing 10 :show-all t
1113    :children (create-radio-button-group '("button1" "button2" "button3") 1)))
1114
1115
1116 ;;; Rangle controls
1117
1118 (define-simple-dialog create-range-controls (dialog "Range controls")
1119   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1120     (make-instance 'v-box
1121      :parent dialog :border-width 10 :spacing 10 :show-all t
1122      :child (make-instance 'h-scale
1123              :width-request 150 :adjustment adjustment :inverted t
1124              :update-policy :delayed :digits 1 :draw-value t)
1125      :child (make-instance 'h-scrollbar
1126              :adjustment adjustment :update-policy :continuous))))
1127
1128
1129 ;;; Reparent test
1130
1131 (define-simple-dialog create-reparent (dialog "Reparent")
1132   (let ((main (make-instance 'h-box
1133                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1134         (label (make-instance 'label :label "Hellow World")))
1135
1136     (flet ((create-frame (title)
1137              (let* ((frame (make-instance 'frame :label title :parent main))
1138                     (box (make-instance 'v-box
1139                           :spacing 5 :border-width 5 :parent frame))
1140                     (button (make-instance 'button
1141                              :label "switch" :parent (list box :expand nil))))
1142                (signal-connect button 'clicked
1143                 #'(lambda ()
1144                     (widget-reparent label box)))
1145                box)))
1146
1147       (box-pack-start (create-frame "Frame 1") label nil t 0)
1148       (create-frame "Frame 2"))
1149     (widget-show-all main)))
1150
1151
1152 ;;; Rulers
1153
1154 (define-toplevel create-rulers (window "Rulers"
1155                                 :default-width 300 :default-height 300
1156 ;;                              :events '(:pointer-motion-mask
1157 ;;                                        :pointer-motion-hint-mask)
1158                                 )
1159   (setf
1160    (widget-events window)
1161    '(:pointer-motion-mask :pointer-motion-hint-mask))
1162
1163   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
1164     (let ((ruler (make-instance 'h-ruler
1165                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1166                   :position 0.0d0 :max-size 20.0d0)))
1167       (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1168       (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
1169     (let ((ruler (make-instance 'v-ruler
1170                   :lower 5.0d0 :upper 15.0d0
1171                   :position 0.0d0 :max-size 20.0d0)))
1172       (signal-connect window 'motion-notify-event #'widget-event :object ruler)
1173       (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
1174
1175
1176
1177 ;;; Scrolled window
1178
1179 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1180                                                       :default-width 300
1181                                                       :default-height 300)
1182   (let* ((scrolled-window
1183           (make-instance 'scrolled-window
1184            :parent dialog :border-width 10
1185            :vscrollbar-policy :automatic
1186            :hscrollbar-policy :automatic))
1187          (table
1188           (make-instance 'table
1189            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1190            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1191            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1192
1193       (scrolled-window-add-with-viewport scrolled-window table)
1194       (dotimes (i 20)
1195         (dotimes (j 20)
1196           (let ((button
1197                  (make-instance 'toggle-button
1198                   :label (format nil "button (~D,~D)~%" i j))))
1199             (table-attach table button i (1+ i) j (1+ j)))))
1200       (widget-show-all scrolled-window)))
1201
1202
1203 ;;; Shapes
1204
1205 ;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1206 ;;   (let* ((window
1207 ;;        (make-instance 'window
1208 ;;         :type type :x x :y y
1209 ;;         :events '(:button-motion :pointer-motion-hint :button-press)))
1210 ;;       (fixed
1211 ;;        (make-instance 'fixed
1212 ;;         :parent window :width 100 :height 100)))
1213
1214 ;;     (widget-realize window)
1215 ;;     (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1216 ;;       (let ((pixmap (pixmap-new source mask))
1217 ;;          (x-offset 0)
1218 ;;          (y-offset 0))
1219 ;;      (declare (fixnum x-offset y-offset))
1220 ;;      (fixed-put fixed pixmap px py)
1221 ;;      (widget-shape-combine-mask window mask px py)
1222
1223 ;;      (signal-connect window 'button-press-event
1224 ;;       #'(lambda (event)
1225 ;;           (when (typep event 'gdk:button-press-event)
1226 ;;             (setq x-offset (truncate (gdk:event-x event)))
1227 ;;             (setq y-offset (truncate (gdk:event-y event)))
1228 ;;             (grab-add window)
1229 ;;             (gdk:pointer-grab
1230 ;;              (widget-window window) t
1231 ;;              '(:button-release :button-motion :pointer-motion-hint)
1232 ;;              nil nil 0))
1233 ;;           t))
1234
1235 ;;      (signal-connect window 'button-release-event
1236 ;;       #'(lambda (event)
1237 ;;           (declare (ignore event))
1238 ;;           (grab-remove window)
1239 ;;           (gdk:pointer-ungrab 0)
1240 ;;           t))
1241
1242 ;;      (signal-connect window 'motion-notify-event
1243 ;;       #'(lambda (event)
1244 ;;           (declare (ignore event))
1245 ;;           (multiple-value-bind (win xp yp mask)
1246 ;;               (gdk:window-get-pointer root-window)
1247 ;;             (declare (ignore mask win) (fixnum xp yp))
1248 ;;             (widget-set-uposition
1249 ;;              window :x (- xp x-offset) :y (- yp y-offset)))
1250 ;;           t))
1251 ;;      (signal-connect window 'destroy destroy)))
1252
1253 ;;     (widget-show-all window)
1254 ;;     window))
1255
1256
1257 ;; (let ((modeller nil)
1258 ;;       (sheets nil)
1259 ;;       (rings nil))
1260 ;;   (defun create-shapes ()
1261 ;;     (let ((root-window (gdk:get-root-window)))
1262 ;;       (if (not modeller)
1263 ;;        (setq
1264 ;;         modeller
1265 ;;         (shape-create-icon
1266 ;;          "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1267 ;;          #'(lambda () (widget-destroyed modeller))))
1268 ;;      (widget-destroy modeller))
1269
1270 ;;       (if (not sheets)
1271 ;;        (setq
1272 ;;         sheets
1273 ;;         (shape-create-icon
1274 ;;          "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1275 ;;          #'(lambda () (widget-destroyed sheets))))
1276 ;;      (widget-destroy sheets))
1277
1278 ;;       (if (not rings)
1279 ;;        (setq
1280 ;;         rings
1281 ;;         (shape-create-icon
1282 ;;          "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1283 ;;          #'(lambda () (widget-destroyed rings))))
1284 ;;      (widget-destroy rings)))))
1285
1286
1287
1288 ;;; Spin buttons
1289
1290 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1291   (let ((main (make-instance 'v-box
1292                :spacing 5 :border-width 10 :parent dialog)))
1293
1294     (flet ((create-date-spinner (label adjustment shadow-type)
1295              (declare (ignore shadow-type))
1296              (make-instance 'v-box
1297               :child-args '(:expand nil)
1298               :child (make-instance 'label
1299                       :label label :xalign 0.0 :yalign 0.5)
1300               :child (make-instance 'spin-button
1301                       :adjustment adjustment :wrap t))))
1302       (make-instance 'frame
1303        :label "Not accelerated" :parent main
1304        :child (make-instance 'h-box
1305                :border-width 10
1306                :child-args '(:padding 5)
1307                :child (create-date-spinner "Day : "
1308                        (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1309                :child (create-date-spinner "Month : "
1310                        (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
1311                :child (create-date-spinner "Year : "
1312                        (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1313
1314     (let ((spinner1 (make-instance 'spin-button
1315                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1316                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1317           (spinner2 (make-instance 'spin-button
1318                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1319                      :climb-rate 1.0 :wrap t))
1320           (value-label (make-instance 'label :label "0")))
1321       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1322        #'(lambda ()
1323            (setf
1324             (spin-button-digits spinner1)
1325             (floor (spin-button-value spinner2)))))
1326
1327       (make-instance 'frame
1328        :label "Accelerated" :parent main
1329        :child (make-instance 'v-box
1330                :border-width 5
1331                :child (list
1332                        (make-instance 'h-box
1333                         :child-args '(:padding 5)
1334                         :child (make-instance 'v-box
1335                                 :child (make-instance 'label
1336                                         :label "Value :"
1337                                         :xalign 0.0 :yalign 0.5)
1338                                 :child spinner1)
1339                         :child (make-instance 'v-box
1340                                 :child (make-instance 'label
1341                                         :label "Digits :"
1342                                         :xalign 0.0 :yalign 0.5)
1343                                 :child spinner2))
1344                        :expand nil :padding 5)
1345                :child (make-instance 'check-button
1346                        :label "Snap to 0.5-ticks" :active t
1347                        :signal (list 'clicked
1348                                 #'(lambda (button)
1349                                     (setf
1350                                      (spin-button-snap-to-ticks-p spinner1)
1351                                      (toggle-button-active-p button)))
1352                                 :object t))
1353                :child (make-instance 'check-button
1354                        :label "Numeric only input mode" :active t
1355                        :signal (list 'clicked
1356                                 #'(lambda (button)
1357                                     (setf
1358                                      (spin-button-numeric-p spinner1)
1359                                      (toggle-button-active-p button)))
1360                                 :object t))
1361                :child value-label
1362                :child (list
1363                        (make-instance 'h-box
1364                         :child-args '(:padding 5)
1365                         :child (make-instance 'button
1366                                 :label "Value as Int"
1367                                 :signal (list 'clicked
1368                                          #'(lambda ()
1369                                              (setf
1370                                               (label-label value-label)
1371                                               (format nil "~D"
1372                                                (spin-button-value-as-int
1373                                                 spinner1))))))
1374                         :child (make-instance 'button
1375                                 :label "Value as Float"
1376                                 :signal (list 'clicked
1377                                          #'(lambda ()
1378                                              (setf
1379                                               (label-label value-label)
1380                                               (format nil
1381                                                (format nil "~~,~DF"
1382                                                 (spin-button-digits spinner1))
1383                                                (spin-button-value spinner1)))))))
1384                        :padding 5 :expand nil))))
1385     (widget-show-all main)))
1386
1387
1388 ;;; Statusbar
1389
1390 (define-toplevel create-statusbar (window "Statusbar")
1391   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1392         (close-button (create-button '("close" :can-default t)
1393                        #'widget-destroy :object window))
1394         (counter 0))
1395
1396     (signal-connect statusbar 'text-popped
1397      #'(lambda (context-id text)
1398          (declare (ignore context-id))
1399          (format nil "Popped: ~A~%" text)))
1400
1401     (make-instance 'v-box
1402      :parent window
1403      :child (make-instance 'v-box
1404              :border-width 10 :spacing 10
1405              :child (create-button "push something"
1406                      #'(lambda ()
1407                          (statusbar-push statusbar 1
1408                           (format nil "something ~D" (incf counter)))))
1409              :child (create-button "pop"
1410                      #'(lambda ()
1411                          (statusbar-pop statusbar 1)))
1412              :child (create-button "steal #4"
1413                      #'(lambda ()
1414                          (statusbar-remove statusbar 1 4)))
1415              :child (create-button "dump stack")
1416              :child (create-button "test contexts"))
1417      :child (list (make-instance 'h-separator) :expand nil)
1418      :child (list
1419              (make-instance 'v-box :border-width 10 :child close-button)
1420              :expand nil)
1421      :child (list statusbar :expand nil))
1422
1423     (widget-grab-focus close-button)))
1424
1425
1426 ;;; Idle test
1427
1428 ;; (define-standard-dialog create-idle-test "Idle Test"
1429 ;;   (let* ((container (make-instance 'hbox :parent main-box))
1430 ;;       (label (make-instance 'label
1431 ;;               :label "count: 0" :xpad 10 :ypad 10 :parent container))
1432 ;;       (idle nil)
1433 ;;       (count 0))
1434 ;;     (declare (fixnum count))
1435 ;;     (signal-connect
1436 ;;      window 'destroy #'(lambda () (when idle (idle-remove idle))))
1437
1438 ;;     (make-instance 'frame
1439 ;;      :label "Label Container" :border-width 5 :parent main-box
1440 ;;      :child
1441 ;;      (make-instance 'v-box
1442 ;;       :children
1443 ;;       (create-radio-button-group
1444 ;;        '(("Resize-Parent" :parent)
1445 ;;       ("Resize-Queue" :queue)
1446 ;;       ("Resize-Immediate" :immediate))
1447 ;;        0
1448 ;;        '(setf container-resize-mode) container)))
1449
1450 ;;     (make-instance 'button
1451 ;;      :label "start" :can-default t :parent action-area
1452 ;;      :signals
1453 ;;      (list
1454 ;;       (list
1455 ;;        'clicked
1456 ;;        #'(lambda ()
1457 ;;         (unless idle
1458 ;;           (setq
1459 ;;            idle
1460 ;;            (idle-add
1461 ;;             #'(lambda ()
1462 ;;                 (incf count)
1463 ;;                 (setf (label-label label) (format nil "count: ~D" count))
1464 ;;                 t))))))))
1465
1466 ;;     (make-instance 'button
1467 ;;      :label "stop" :can-default t :parent action-area
1468 ;;      :signals
1469 ;;      (list
1470 ;;       (list
1471 ;;        'clicked
1472 ;;        #'(lambda ()
1473 ;;         (when idle
1474 ;;           (idle-remove idle)
1475 ;;           (setq idle nil))))))))
1476
1477
1478
1479 ;;; Timeout test
1480
1481 ;; (define-standard-dialog create-timeout-test "Timeout Test"
1482 ;;   (let ((label (make-instance 'label
1483 ;;              :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
1484 ;;      (timer nil)
1485 ;;      (count 0))
1486 ;;     (declare (fixnum count))
1487 ;;     (signal-connect
1488 ;;      window 'destroy #'(lambda () (when timer (timeout-remove timer))))
1489
1490 ;;     (make-instance 'button
1491 ;;      :label "start" :can-default t :parent action-area
1492 ;;      :signals
1493 ;;      (list
1494 ;;       (list
1495 ;;        'clicked
1496 ;;        #'(lambda ()
1497 ;;         (unless timer
1498 ;;           (setq
1499 ;;            timer
1500 ;;            (timeout-add
1501 ;;             100
1502 ;;             #'(lambda ()
1503 ;;                 (incf count)
1504 ;;                 (setf (label-label label) (format nil "count: ~D" count))
1505 ;;                 t))))))))
1506
1507 ;;     (make-instance 'button
1508 ;;      :label "stop" :can-default t :parent action-area
1509 ;;      :signals
1510 ;;      (list
1511 ;;       (list
1512 ;;        'clicked
1513 ;;        #'(lambda ()
1514 ;;         (when timer
1515 ;;           (timeout-remove timer)
1516 ;;           (setq timer nil))))))))
1517
1518
1519 ;;; Text
1520
1521 (define-simple-dialog create-text (dialog "Text" :default-width 400
1522                                                  :default-height 400)
1523   (make-instance 'text-view :border-width 10  :parent dialog :visible t))
1524
1525 ;;; Toggle buttons
1526
1527 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1528   (make-instance 'v-box
1529    :border-width 10 :spacing 10 :parent dialog :show-all t
1530       :children (loop
1531               for n from 1 to 3
1532               collect (make-instance 'toggle-button
1533                        :label (format nil "Button~D" (1+ n))))))
1534
1535
1536
1537 ;;; Toolbar test
1538
1539 ;; TODO: style properties
1540 (define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1541   (let ((toolbar (make-instance 'toolbar :parent window)))
1542 ;    (setf (toolbar-relief toolbar) :none)
1543
1544     ;; Insert a stock item
1545     (toolbar-append toolbar "gtk-quit"
1546      :tooltip-text "Destroy toolbar"
1547      :tooltip-private-text "Toolbar/Quit"
1548      :callback #'(lambda () (widget-destroy window)))
1549
1550     ;; Image widge as icon
1551     (toolbar-append toolbar "Horizontal"
1552      :icon (make-instance 'image :file #p"clg:examples;test.xpm")
1553      :tooltip-text "Horizontal toolbar layout"
1554      :tooltip-private-text "Toolbar/Horizontal"
1555      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1556
1557     ;; Icon from file
1558     (toolbar-append toolbar "Vertical"
1559      :icon #p"clg:examples;test.xpm"
1560      :tooltip-text "Vertical toolbar layout"
1561      :tooltip-private-text "Toolbar/Vertical"
1562      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1563
1564     (toolbar-append toolbar :space)
1565
1566     ;; Stock icon
1567     (toolbar-append toolbar "Icons"
1568      :icon "gtk-execute"
1569      :tooltip-text "Only show toolbar icons"
1570      :tooltip-private-text "Toolbar/IconsOnly"
1571      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1572
1573     ;; Icon from pixmap data
1574     (toolbar-append toolbar "Text"
1575      :icon gtk-mini-xpm
1576      :tooltip-text "Only show toolbar text"
1577      :tooltip-private-text "Toolbar/TextOnly"
1578      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1579
1580     (toolbar-append toolbar "Both"
1581      :tooltip-text "Show toolbar icons and text"
1582      :tooltip-private-text "Toolbar/Both"
1583      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1584
1585     (toolbar-append toolbar :space)
1586
1587     (toolbar-append toolbar (make-instance 'entry)
1588      :tooltip-text "This is an unusable GtkEntry"
1589      :tooltip-private-text "Hey don't click me!")
1590
1591     (toolbar-append toolbar :space)
1592
1593 ;;     (toolbar-append-item
1594 ;;      toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1595 ;;      :tooltip-text "Use small spaces"
1596 ;;      :tooltip-private-text "Toolbar/Small"
1597 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1598
1599 ;;     (toolbar-append-item
1600 ;;      toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1601 ;;      :tooltip-text "Use big spaces"
1602 ;;      :tooltip-private-text "Toolbar/Big"
1603 ;;      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1604
1605 ;;     (toolbar-append toolbar :space)
1606
1607     (toolbar-append
1608      toolbar "Enable"
1609      :tooltip-text "Enable tooltips"
1610      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1611
1612     (toolbar-append
1613      toolbar "Disable"
1614      :tooltip-text "Disable tooltips"
1615      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1616
1617     (toolbar-append toolbar :space)
1618
1619 ;;     (toolbar-append-item
1620 ;;      toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1621 ;;      :tooltip-text "Show borders"
1622 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1623
1624 ;;     (toolbar-append-item
1625 ;;      toolbar
1626 ;;      "Borderless" (pixmap-new "clg:examples;test.xpm")
1627 ;;      :tooltip-text "Hide borders"
1628 ;;      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1629
1630 ;;     (toolbar-append toolbar :space)
1631
1632 ;;     (toolbar-append-item
1633 ;;      toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1634 ;;      :tooltip-text "Empty spaces"
1635 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1636
1637 ;;     (toolbar-append-item
1638 ;;      toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1639 ;;      :tooltip-text "Lines in spaces"
1640 ;;      :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
1641
1642     ))
1643
1644
1645
1646 ;;; Tooltips test
1647
1648 ;; (define-standard-dialog create-tooltips "Tooltips"
1649 ;;   (setf
1650 ;;    (window-allow-grow-p window) t
1651 ;;    (window-allow-shrink-p window) nil
1652 ;;    (window-auto-shrink-p window) t
1653 ;;    (widget-width window) 200
1654 ;;    (container-border-width main-box) 10
1655 ;;    (box-spacing main-box) 10)
1656
1657 ;;   (let ((tooltips (tooltips-new)))
1658 ;;     (flet ((create-button (label tip-text tip-private)
1659 ;;           (let ((button (make-instance 'toggle-button
1660 ;;                  :label label :parent main-box)))
1661 ;;             (tooltips-set-tip tooltips button tip-text tip-private)
1662 ;;             button)))
1663 ;;       (create-button "button1" "This is button 1" "ContextHelp/button/1")
1664 ;;       (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")
1665
1666 ;;       (let* ((toggle (create-button "Override TipSQuery Label"
1667 ;;                                  "Toggle TipsQuery view" "Hi msw! ;)"))
1668 ;;           (box (make-instance 'v-box
1669 ;;                 :homogeneous nil :spacing 5 :border-width 5
1670 ;;                 :parent (make-instance 'frame
1671 ;;                          :label "ToolTips Inspector"
1672 ;;                          :label-xalign 0.5 :border-width 0
1673 ;;                          :parent main-box)))
1674 ;;           (button (make-instance 'button :label "[?]" :parent box))
1675 ;;           (tips-query (make-instance 'tips-query
1676 ;;                        :caller button :parent box)))
1677
1678 ;;      (signal-connect
1679 ;;       button 'clicked #'tips-query-start-query :object tips-query)
1680
1681 ;;      (signal-connect
1682 ;;       tips-query 'widget-entered
1683 ;;       #'(lambda (widget tip-text tip-private)
1684 ;;           (declare (ignore widget tip-private))
1685 ;;           (when (toggle-button-active-p toggle)
1686 ;;             (setf
1687 ;;              (label-label tips-query)
1688 ;;              (if tip-text
1689 ;;                  "There is a Tip!"
1690 ;;                "There is no Tip!"))
1691 ;;             (signal-emit-stop tips-query 'widget-entered))))
1692
1693 ;;      (signal-connect
1694 ;;       tips-query 'widget-selected
1695 ;;       #'(lambda (widget tip-text tip-private event)
1696 ;;           (declare (ignore tip-text event))
1697 ;;           (when widget
1698 ;;             (format
1699 ;;              t "Help ~S requested for ~S~%"
1700 ;;              (or tip-private "None") (type-of widget)))
1701 ;;           t))
1702
1703 ;;      (tooltips-set-tip
1704 ;;       tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1705 ;;      (tooltips-set-tip
1706 ;;       tooltips close-button "Push this button to close window"
1707 ;;       "ContextHelp/buttons/Close")))))
1708
1709
1710 ;;; UI Manager
1711
1712 (defvar *ui-description*
1713   '((:menubar "MenuBar"
1714      (:menu "FileMenu"
1715       (:menuitem "New")
1716       (:menuitem "Open")
1717       (:menuitem "Save")
1718       (:menuitem "SaveAs")
1719       :separator
1720       (:menuitem "Quit"))
1721      (:menu "PreferencesMenu"
1722        (:menu "ColorMenu"
1723         (:menuitem "Red")
1724         (:menuitem "Green")
1725         (:menuitem "Blue"))
1726        (:menu "ShapeMenu"
1727         (:menuitem "Square")
1728         (:menuitem "Rectangle")
1729         (:menuitem "Oval"))
1730        (:menuitem "Bold"))
1731      (:menu "HelpMenu"
1732       (:menuitem "About")))
1733     (:toolbar "ToolBar"
1734      (:toolitem "Open")
1735      (:toolitem "Quit")
1736      (:separator "Sep1")
1737      (:toolitem "Logo"))))
1738
1739 (define-simple-dialog create-ui-manager (dialog "UI Manager")
1740   (let ((actions
1741          (make-instance 'action-group
1742           :name "Actions"
1743           :action (create-action "FileMenu" nil "_File")
1744           :action (create-action "PreferencesMenu" nil "_Preferences")
1745           :action (create-action "ColorMenu" nil "_Color")
1746           :action (create-action "ShapeMenu" nil "_Shape")
1747           :action (create-action "HelpMenu" nil "_Help")
1748           :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1749           :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file")
1750           :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1751           :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1752           :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit")
1753           :action (create-action "About" nil "_About" "<control>A" "About")
1754           :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1755           :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1756           :actions (create-radio-actions
1757                     '(("Red" nil "_Red" "<control>R" "Blood")
1758                       ("Green" nil "_Green" "<control>G" "Grass")
1759                       ("Blue" nil "_Blue" "<control>B" "Sky"))
1760                     "Green")
1761           :actions (create-radio-actions
1762                     '(("Square" nil "_Square" "<control>S" "Square")
1763                       ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1764                       ("Oval" nil "_Oval" "<control>O" "Egg")))))
1765         (ui (make-instance 'ui-manager)))
1766
1767     (ui-manager-insert-action-group ui actions)
1768     (ui-manager-add-ui ui *ui-description*)
1769
1770     (window-add-accel-group dialog (ui-manager-accel-group ui))
1771
1772     (make-instance 'v-box
1773      :parent dialog :show-all t
1774      :child (list
1775              (ui-manager-get-widget ui "/MenuBar")
1776              :expand nil :fill nil)
1777      :child (list
1778              (ui-manager-get-widget ui "/ToolBar")
1779              :expand nil :fill nil)
1780      :child (make-instance 'label
1781              :label "Type <alt> to start"
1782              :xalign 0.5 :yalign 0.5
1783              :width-request 200 :height-request 200))))
1784
1785
1786
1787 ;;; Main window
1788
1789 (defun create-main-window ()
1790 ;;   (rc-parse "clg:examples;testgtkrc2")
1791 ;;   (rc-parse "clg:examples;testgtkrc")
1792
1793   (let* ((button-specs
1794           '(("button box" create-button-box)
1795             ("buttons" create-buttons)
1796             ("calendar" create-calendar)
1797             ("check buttons" create-check-buttons)
1798             ("color selection" create-color-selection)
1799 ;;          ("cursors" #|create-cursors|#)
1800             ("dialog" create-dialog)
1801 ;; ;        ("dnd")
1802             ("entry" create-entry)
1803 ;;          ("event watcher")
1804             ("file chooser" create-file-chooser)
1805 ;;          ("font selection")
1806 ;;          ("handle box" create-handle-box)
1807             ("image" create-image)
1808 ;;          ("item factory")
1809             ("labels" create-labels)
1810             ("layout" create-layout)
1811             ("list" create-list)
1812             ("menus" create-menus)
1813 ;;          ("modal window")
1814             ("notebook" create-notebook)
1815             ("panes" create-panes)
1816 ;;          ("progress bar" #|create-progress-bar|#)
1817             ("radio buttons" create-radio-buttons)
1818             ("range controls" create-range-controls)
1819 ;;          ("rc file")
1820             ("reparent" create-reparent)
1821             ("rulers" create-rulers)
1822 ;;          ("saved position")
1823             ("scrolled windows" create-scrolled-windows)
1824 ;;          ("shapes" create-shapes)
1825             ("spinbutton" create-spins)
1826             ("statusbar" create-statusbar)
1827 ;;          ("test idle" create-idle-test)
1828 ;;          ("test mainloop")
1829 ;;          ("test scrolling")
1830 ;;          ("test selection")
1831 ;;          ("test timeout" create-timeout-test)
1832             ("text" create-text)
1833             ("toggle buttons" create-toggle-buttons)
1834             ("toolbar" create-toolbar)
1835 ;;          ("tooltips" create-tooltips)
1836 ;;          ("tree" #|create-tree|#)
1837             ("UI manager" create-ui-manager)
1838 ))
1839         (main-window (make-instance 'window
1840                       :title "testgtk.lisp" :name "main_window"
1841                       :default-width 200 :default-height 400
1842                       :allow-grow t :allow-shrink nil))
1843         (scrolled-window (make-instance 'scrolled-window
1844                           :hscrollbar-policy :automatic
1845                           :vscrollbar-policy :automatic
1846                           :border-width 10))
1847         (close-button (make-instance 'button
1848                        :label "close" :can-default t
1849                        :signal (list 'clicked #'widget-destroy
1850                                      :object main-window))))
1851
1852     ;; Main box
1853     (make-instance 'v-box
1854      :parent main-window
1855      :child-args '(:expand nil)
1856      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1857      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1858      :child (list scrolled-window :expand t)
1859      :child (make-instance 'h-separator)
1860      :child (make-instance 'v-box
1861              :homogeneous nil :spacing 10 :border-width 10
1862              :child close-button))
1863
1864     (let ((content-box
1865            (make-instance 'v-box
1866             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1867             :children (mapcar #'(lambda (spec)
1868                                   (apply #'create-button spec))
1869                               button-specs))))
1870       (scrolled-window-add-with-viewport scrolled-window content-box))
1871
1872     (widget-grab-focus close-button)
1873     (widget-show-all main-window)
1874     main-window))
1875
1876 (clg-init)
1877 (create-main-window)