mdw@git.distorted.org.uk Git - clg/blob - examples/testgtk.lisp

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