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

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