chiark - git - mdw - clg/blob - examples/testgtk.lisp

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