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