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.41 2007-07-12 09:18:30 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" "CLG"))
  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 #+(or cmu sbcl)
 501 (defun get-directory-listing (directory)
 502   (let ((dir #+cmu(unix:open-dir directory)
 503              #+sbcl(sb-posix:opendir directory)))
 504     (unwind-protect
 505         (loop
 506          as filename = #+cmu(unix:read-dir dir)
 507                        #+sbcl(let ((dirent (sb-posix:readdir dir)))
 508                                (unless (sb-grovel::foreign-nullp dirent)
 509                                  (sb-posix:dirent-name dirent)))
 510          while filename
 511          collect (let* ((pathname (format nil "~A~A" directory filename))
 512                         (directory-p
 513                          #+cmu(eq (unix:unix-file-kind pathname) :directory)
 514                          #+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
 515                    (list filename directory-p)))
 516       #+cmu(unix:close-dir dir)
 517       #+sbcl(sb-posix:closedir dir))))
 518
 519 #+clisp
 520 (defun get-directory-listing (directory)
 521   (nconc
 522    (mapcar #'(lambda (entry)
 523                (let ((pathname (namestring (first entry))))
 524                  (list (subseq pathname (1+ (position #\/ pathname :from-end t))) nil)))
 525     (directory (format nil "~A*" directory) :full t))
 526    (mapcar #'(lambda (entry)
 527                (let ((pathname (namestring entry)))
 528                  (list (subseq pathname (1+ (position #\/ pathname :from-end t :end (1- (length pathname)))) (1- (length pathname))) nil)))
 529
 530     (directory (format nil "~A*/" directory)))))
 531
 532
 533 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
 534 (let ((file-pixbuf nil)
 535       (folder-pixbuf nil))
 536   (defun load-pixbufs ()
 537     (unless file-pixbuf
 538       (handler-case
 539           (setf
 540            file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
 541            folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
 542         (glib:glib-error (condition)
 543           (make-instance 'message-dialog
 544            :message-type :error :visible t
 545            :text "<b>Failed to load an image</b>"
 546            :secondary-text (glib:gerror-message condition)
 547            :signal (list :ok #'widget-destroy :object t))
 548           (return-from load-pixbufs nil))))
 549     t)
 550
 551   (defun fill-store (store directory)
 552     (list-store-clear store)
 553     (loop
 554      for (filename directory-p) in (get-directory-listing directory)
 555      unless (or (string= filename ".") (string= filename ".."))
 556      do (list-store-insert store 0
 557          (vector
 558           filename
 559           (if directory-p folder-pixbuf file-pixbuf)
 560           directory-p))))
 561
 562   (defun sort-func (store a b)
 563     (let ((a-dir-p (tree-model-value store a 'directory-p))
 564           (b-dir-p (tree-model-value store b 'directory-p))
 565           (a-name (tree-model-value store a 'filename))
 566           (b-name (tree-model-value store b 'filename)))
 567       (cond
 568        ((and a-dir-p (not b-dir-p)) :before)
 569        ((and (not a-dir-p) b-dir-p) :after)
 570        ((string< a-name b-name) :before)
 571        ((string> a-name b-name) :after)
 572        (t :equal))))
 573
 574
 575   (defun parent-dir (dir)
 576     (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
 577       (subseq dir 0 end)))
 578
 579   (define-toplevel create-icon-view (window "Icon View demo"
 580                                      :default-width 650
 581                                      :default-height 400)
 582     (if (not (load-pixbufs))
 583         (widget-destroy window)
 584       (let* ((directory "/")
 585              (store (make-instance 'list-store
 586                      :column-types '(string gdk:pixbuf boolean)
 587                      :column-names '(filename pixbuf directory-p)))
 588              (icon-view (make-instance 'icon-view
 589                          :model store :selection-mode :multiple
 590                          :text-column 'filename
 591                          :pixbuf-column 'pixbuf))
 592              (up (make-instance 'tool-button
 593                   :stock "gtk-go-up" :is-important t :sensitive nil))
 594              (home (make-instance 'tool-button
 595                     :stock  "gtk-home" :is-important t)))
 596         (tree-sortable-set-sort-func store :default #'sort-func)
 597         (tree-sortable-set-sort-column store :default :ascending)
 598         (fill-store store directory)
 599
 600         (signal-connect icon-view 'item-activated
 601          #'(lambda (path)
 602              (when (tree-model-value store path 'directory-p)
 603                (setq directory
 604                 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
 605                (fill-store store directory)
 606                (setf (widget-sensitive-p up) t))))
 607
 608         (signal-connect up 'clicked
 609          #'(lambda ()
 610              (unless (string= directory "/")
 611                (setq directory (parent-dir directory))
 612                (fill-store store directory)
 613                (setf
 614                 (widget-sensitive-p home)
 615                 (not (string= directory (namestring (truename #p"clg:")))))
 616                (setf (widget-sensitive-p up) (not (string= directory "/"))))))
 617
 618         (signal-connect home 'clicked
 619          #'(lambda ()
 620              (setq directory (namestring (truename #p"clg:")))
 621              (fill-store store directory)
 622              (setf (widget-sensitive-p up) t)
 623              (setf (widget-sensitive-p home) nil)))
 624
 625         (make-instance 'v-box
 626          :parent window
 627          :child (list
 628                  (make-instance 'toolbar :child up :child home)
 629                  :fill nil :expand nil)
 630          :child (make-instance 'scrolled-window
 631                  :shadow-type :etched-in :policy :automatic
 632                  :child icon-view))))))
 633
 634
 635 ;;; Image
 636
 637 (define-toplevel create-image (window "Image" :resizable nil)
 638   (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
 639
 640
 641 ;;; Labels
 642
 643 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 644   (flet ((create-label-in-frame (frame-label label-text &rest args)
 645            (make-instance 'frame
 646             :label frame-label
 647             :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
 648     (make-instance 'h-box
 649      :spacing 5 :parent window
 650      :child-args '(:fill nil :expand nil)
 651      :child (make-instance 'v-box
 652              :spacing 5 :child-args '(:fill nil :expand nil)
 653              :child (create-label-in-frame "Normal Label" "This is a Normal label")
 654              :child (create-label-in-frame "Multi-line Label"
 655 "This is a Multi-line label.
 656 Second line
 657 Third line")
 658              :child (create-label-in-frame "Left Justified Label"
 659 "This is a Left-Justified
 660 Multi-line.
 661 Third line"
 662                       :justify :left)
 663              :child (create-label-in-frame "Right Justified Label"
 664 "This is a Right-Justified
 665 Multi-line.
 666 Third line"
 667                      :justify :right))
 668      :child (make-instance 'v-box
 669              :spacing 5 :child-args '(:fill nil :expand nil)
 670              :child (create-label-in-frame "Line wrapped label"
 671 "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.
 672      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
 673                       :wrap t)
 674
 675              :child (create-label-in-frame "Filled, wrapped label"
 676 "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.
 677     This is a new paragraph.
 678     This is another newer, longer, better paragraph.  It is coming to an end, unfortunately."
 679                       :justify :fill :wrap t)
 680
 681              :child (create-label-in-frame "Underlined label"
 682 "This label is underlined!
 683 This one is underlined in quite a funky fashion"
 684                       :justify :left
 685                       :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 686
 687
 688 ;;; Layout (Note: using the drawing function in Gdk is considered
 689 ;;; deprecated in clg, new code should use Cairo instead)
 690
 691 (defun layout-expose (layout event)
 692   (when (eq (gdk:event-window event) (layout-bin-window layout))
 693     (with-slots (gdk:x gdk:y gdk:width gdk:height) event
 694       (let ((imin (truncate gdk:x 10))
 695             (imax (truncate (+ gdk:x gdk:width 9) 10))
 696             (jmin (truncate gdk:y 10))
 697             (jmax (truncate (+ gdk:y gdk:height 9) 10)))
 698
 699         (let ((window (layout-bin-window layout))
 700               (gc (style-black-gc (widget-style layout))))
 701           (loop
 702            for i from imin below imax
 703            do (loop
 704                for j from jmin below jmax
 705                unless (zerop (mod (+ i j) 2))
 706                do (gdk:draw-rectangle
 707                    window gc t (* 10 i) (* 10 j)
 708                    (1+ (mod i 10)) (1+ (mod j 10)))))))))
 709   nil)
 710
 711 (define-toplevel create-layout (window "Layout" :default-width 200
 712                                                 :default-height 200)
 713   (let ((layout (make-instance 'layout
 714                  :parent (make-instance 'scrolled-window :parent window)
 715                  :width 1600 :height 128000 :events '(:exposure)
 716                  :signal (list 'expose-event #'layout-expose :object t))))
 717
 718     (with-slots (hadjustment vadjustment) layout
 719       (setf
 720        (adjustment-step-increment hadjustment) 10.0
 721        (adjustment-step-increment vadjustment) 10.0))
 722
 723     (dotimes (i 16)
 724       (dotimes (j 16)
 725         (let ((text (format nil "Button ~D, ~D" i j)))
 726           (layout-put layout
 727            (make-instance (if (not (zerop (mod (+ i j) 2)))
 728                               'button
 729                             'label)
 730                           :label text :visible t)
 731            (* j 100) (* i 100)))))
 732
 733     (loop
 734      for i from 16 below 1280
 735      do (let ((text (format nil "Button ~D, ~D" i 0)))
 736           (layout-put layout
 737            (make-instance (if (not (zerop (mod i 2)))
 738                               'button
 739                             'label)
 740                           :label text :visible t)
 741            0 (* i 100))))))
 742
 743
 744
 745 ;;; List
 746
 747 (define-simple-dialog create-list (dialog "List" :default-height 400)
 748   (let* ((store (make-instance 'list-store
 749                  :column-types '(string integer boolean)
 750                  :column-names '(:foo :bar :baz)
 751                  :initial-content '(#("First" 12321 nil)
 752                                     (:foo "Yeah" :baz t))))
 753          (tree (make-instance 'tree-view :model store)))
 754
 755     (loop
 756      with iter = (make-instance 'tree-iter)
 757      for i from 1 to 1000
 758      do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
 759
 760     (let ((column (make-instance 'tree-view-column :title "Column 1"))
 761           (cell (make-instance 'cell-renderer-text)))
 762       (cell-layout-pack column cell :expand t)
 763       (cell-layout-add-attribute column cell 'text (tree-model-column-index store :foo))
 764       (tree-view-append-column tree column))
 765
 766     (let ((column (make-instance 'tree-view-column :title "Column 2"))
 767           (cell (make-instance 'cell-renderer-text :background "orange")))
 768       (cell-layout-pack column cell :expand t)
 769       (cell-layout-add-attribute column cell 'text (tree-model-column-index store :bar))
 770       (tree-view-append-column tree column))
 771
 772     (let ((column (make-instance 'tree-view-column :title "Column 3"))
 773           (cell (make-instance 'cell-renderer-text)))
 774       (cell-layout-pack column cell :expand t)
 775       (cell-layout-add-attribute column cell 'text (tree-model-column-index store :baz))
 776       (tree-view-append-column tree column))
 777
 778     (make-instance 'v-box
 779      :parent dialog :border-width 10 :spacing 10
 780      :child (list
 781              (make-instance 'h-box
 782               :spacing 10
 783               :child (make-instance 'button
 784                       :label "Remove Selection"
 785                       :signal (list 'clicked
 786                                #'(lambda ()
 787                                    (let ((references
 788                                           (mapcar
 789                                            #'(lambda (path)
 790                                                (make-instance 'tree-row-reference :model store :path path))
 791                                            (tree-selection-get-selected-rows
 792                                             (tree-view-selection tree)))))
 793                                      (mapc
 794                                       #'(lambda (reference)
 795                                           (list-store-remove store reference))
 796                                       references))))))
 797              :expand nil)
 798      :child (list
 799              (make-instance 'h-box
 800               :spacing 10
 801               :child (make-instance 'check-button
 802                       :label "Show Headers" :active t
 803                       :signal (list 'toggled
 804                                #'(lambda (button)
 805                                    (setf
 806                                     (tree-view-headers-visible-p tree)
 807                                     (toggle-button-active-p button)))
 808                                :object t))
 809               :child (make-instance 'check-button
 810                       :label "Reorderable" :active nil
 811                       :signal (list 'toggled
 812                                #'(lambda (button)
 813                                    (setf
 814                                     (tree-view-reorderable-p tree)
 815                                     (toggle-button-active-p button)))
 816                                :object t))
 817               :child (list
 818                       (make-instance 'h-box
 819                        :child (make-instance 'label :label "Selection Mode: ")
 820                        :child (make-instance 'combo-box
 821                                :content '("Single" "Browse" "Multiple")
 822                                :active 0
 823                                :signal (list 'changed
 824                                         #'(lambda (combo-box)
 825                                             (setf
 826                                              (tree-selection-mode
 827                                               (tree-view-selection tree))
 828                                              (svref
 829                                               #(:single :browse :multiple)
 830                                               (combo-box-active combo-box))))
 831                                         :object t)))
 832                       :expand nil))
 833              :expand nil)
 834      :child (make-instance 'scrolled-window
 835             :child tree :hscrollbar-policy :automatic))))
 836
 837
 838 ;; Menus
 839
 840 (defun create-menu (depth tearoff)
 841   (unless (zerop depth)
 842     (let ((menu (make-instance 'menu)))
 843       (when tearoff
 844         (let ((menu-item (make-instance 'tearoff-menu-item)))
 845           (menu-shell-append menu menu-item)))
 846       (let ((group nil))
 847         (dotimes (i 5)
 848           (let ((menu-item
 849                  (make-instance 'radio-menu-item
 850                   :label (format nil "item ~2D - ~D" depth (1+ i)))))
 851             (if group
 852                 (add-to-radio-group menu-item group)
 853               (setq group menu-item))
 854             (unless (zerop (mod depth 2))
 855               (setf (check-menu-item-active-p menu-item) t))
 856             (menu-shell-append menu menu-item)
 857             (when (= i 3)
 858               (setf (widget-sensitive-p menu-item) nil))
 859             (let ((submenu (create-menu (1- depth) t)))
 860               (when submenu
 861                 (setf (menu-item-submenu menu-item) submenu))))))
 862       menu)))
 863
 864
 865 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 866   (let* ((main (make-instance 'v-box :parent dialog))
 867 ;        (accel-group (make-instance 'accel-group))
 868          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 869 ;    (window-add-accel-group dialog accel-group)
 870
 871     (let ((menu-item (make-instance 'menu-item
 872                       :label (format nil "test~%line2"))))
 873       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 874       (menu-shell-append menubar menu-item))
 875
 876     (let ((menu-item (make-instance 'menu-item :label "foo")))
 877       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 878       (menu-shell-append menubar menu-item))
 879
 880     (let ((menu-item (make-instance 'menu-item :label "bar")))
 881       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 882       (setf (menu-item-right-justified-p menu-item) t)
 883       (menu-shell-append menubar menu-item))
 884
 885     (make-instance 'v-box
 886      :spacing 10 :border-width 10 :parent main
 887      :child (make-instance 'combo-box
 888              :active 3
 889              :content (loop
 890                        for i from 1 to 5
 891                        collect (format nil "Item ~D" i))))
 892
 893     (widget-show-all main)))
 894
 895
 896 ;;; Notebook
 897
 898 (defun create-notebook-page (notebook page-num book-closed)
 899   (let* ((title (format nil "Page ~D" page-num))
 900          (page (make-instance 'frame :label title :border-width 10))
 901          (v-box (make-instance 'v-box
 902                  :homogeneous t :border-width 10 :parent page)))
 903
 904     (make-instance 'h-box
 905      :parent (list v-box :fill nil :padding 5) :homogeneous t
 906      :child-args '(:padding 5)
 907      :child (make-instance 'check-button
 908              :label "Fill Tab" :active t
 909              :signal (list 'toggled
 910                            #'(lambda (button)
 911                                (setf
 912                                 (notebook-child-tab-fill-p page)
 913                                 (toggle-button-active-p button)))
 914                            :object t))
 915      :child (make-instance 'check-button
 916              :label "Expand Tab"
 917              :signal (list 'toggled
 918                            #'(lambda (button)
 919                                (setf
 920                                 (notebook-child-tab-expand-p page)
 921                                 (toggle-button-active-p button)))
 922                            :object t))
 923      :child (make-instance 'check-button
 924              :label "Pack end"
 925              :signal (list 'toggled
 926                            #'(lambda (button)
 927                                (setf
 928                                 (notebook-child-tab-pack page)
 929                                 (if (toggle-button-active-p button)
 930                                     :end
 931                                   :start)))
 932                            :object t))
 933      :child (make-instance 'button
 934              :label "Hide page"
 935              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 936
 937
 938     (let ((label-box (make-instance 'h-box
 939                       :show-children t
 940                       :child-args '(:expand nil)
 941                       :child (make-instance 'image :pixbuf book-closed)
 942                       :child (make-instance 'label :label title)))
 943           (menu-box (make-instance 'h-box
 944                      :show-children t
 945                      :child-args '(:expand nil)
 946                      :child (make-instance 'image :pixbuf book-closed)
 947                      :child (make-instance 'label :label title))))
 948
 949       (notebook-append notebook page label-box menu-box))))
 950
 951 (define-simple-dialog create-notebook (dialog "Notebook")
 952   (let ((main (make-instance 'v-box :parent dialog)))
 953     (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
 954           (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
 955           (notebook (make-instance 'notebook
 956                      :border-width 10 :tab-pos :top :parent main)))
 957
 958       (flet ((set-image (page func pixbuf)
 959                (setf
 960                 (image-pixbuf
 961                  (first (container-children (funcall func notebook page))))
 962                 pixbuf)))
 963         (signal-connect notebook 'switch-page
 964          #'(lambda (pointer page)
 965              (declare (ignore pointer))
 966              (set-image page #'notebook-menu-label book-open)
 967              (set-image page #'notebook-tab-label book-open)
 968              (when (slot-boundp notebook 'current-page)
 969                (let ((curpage (notebook-current-page notebook)))
 970                  (set-image curpage #'notebook-menu-label book-closed)
 971                  (set-image curpage #'notebook-tab-label book-closed))))))
 972       (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
 973
 974       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 975
 976       (make-instance 'h-box
 977        :spacing 5 :border-width 10
 978        :parent (list main :expand nil)
 979        :child-args '(:fill nil)
 980        :child (make-instance 'check-button
 981                :label "Popup menu"
 982                :signal (list 'clicked
 983                         #'(lambda (button)
 984                             (if (toggle-button-active-p button)
 985                                 (notebook-popup-enable notebook)
 986                                 (notebook-popup-disable notebook)))
 987                         :object t))
 988        :child (make-instance 'check-button
 989                :label "Homogeneous tabs"
 990                :signal (list 'clicked
 991                         #'(lambda (button)
 992                             (setf
 993                              (notebook-homogeneous-p notebook)
 994                              (toggle-button-active-p button)))
 995                         :object t)))
 996
 997       (make-instance 'h-box
 998        :spacing 5 :border-width 10
 999        :parent (list main :expand nil)
1000        :child-args '(:expand nil)
1001        :child (make-instance 'label :label "Notebook Style: ")
1002        :child (let ((scrollable-p nil))
1003                 (make-instance 'combo-box
1004                  :content '("Standard" "No tabs" "Scrollable") :active 0
1005                  :signal (list 'changed
1006                           #'(lambda (combo-box)
1007                               (case (combo-box-active combo-box)
1008                                 (0
1009                                  (setf (notebook-show-tabs-p notebook) t)
1010                                  (when scrollable-p
1011                                    (setq scrollable-p nil)
1012                                    (setf (notebook-scrollable-p notebook) nil)
1013                                    (loop repeat 10
1014                                     do (notebook-remove-page notebook 5))))
1015                                 (1
1016                                  (setf (notebook-show-tabs-p notebook) nil)
1017                                  (when scrollable-p
1018                                    (setq scrollable-p nil)
1019                                    (setf (notebook-scrollable-p notebook) nil)
1020                                    (loop repeat 10
1021                                      do (notebook-remove-page notebook 5))))
1022                                 (2
1023                                  (unless scrollable-p
1024                                    (setq scrollable-p t)
1025                                    (setf (notebook-show-tabs-p notebook) t)
1026                                    (setf (notebook-scrollable-p notebook) t)
1027                                    (loop for i from 6 to 15
1028                                     do (create-notebook-page notebook i book-closed))))))
1029                           :object t)))
1030        :child (make-instance 'button
1031                :label "Show all Pages"
1032                :signal (list 'clicked
1033                         #'(lambda ()
1034                             (map-container nil #'widget-show notebook)))))
1035
1036       (make-instance 'h-box
1037        :spacing 5 :border-width 10
1038        :parent (list main :expand nil)
1039        :child (make-instance 'button
1040                :label "Prev"
1041                :signal (list 'clicked #'notebook-prev-page :object notebook))
1042        :child (make-instance 'button
1043                :label "Next"
1044                :signal (list 'clicked #'notebook-next-page :object notebook))
1045        :child (make-instance 'button
1046                :label "Rotate"
1047                :signal (let ((tab-pos 0))
1048                          (list 'clicked
1049                           #'(lambda ()
1050                               (setq tab-pos (mod (1+ tab-pos) 4))
1051                               (setf
1052                                (notebook-tab-pos notebook)
1053                                (svref #(:top :right :bottom :left) tab-pos))))))))
1054     (widget-show-all main)))
1055
1056
1057
1058 ;;; Panes
1059
1060 (defun toggle-resize (child)
1061   (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
1062
1063 (defun toggle-shrink (child)
1064   (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
1065
1066 (defun create-pane-options (paned frame-label label1 label2)
1067   (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
1068     (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
1069     (let ((check-button (make-instance 'check-button :label "Resize")))
1070       (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
1071       (signal-connect check-button 'toggled
1072        #'toggle-resize :object (paned-child1 paned)))
1073     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1074       (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
1075       (signal-connect check-button 'toggled
1076        #'toggle-shrink :object (paned-child1 paned)))
1077
1078     (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
1079     (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
1080       (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
1081       (signal-connect check-button 'toggled
1082        #'toggle-resize :object (paned-child2 paned)))
1083     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
1084       (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
1085       (signal-connect check-button 'toggled
1086        #'toggle-shrink :object (paned-child2 paned)))
1087     (make-instance 'frame :label frame-label :border-width 4 :child table)))
1088
1089 (define-toplevel create-panes (window "Panes")
1090   (let* ((hpaned (make-instance 'h-paned
1091                   :child1 (make-instance 'frame
1092                            :width-request 60 :height-request 60
1093                            :shadow-type :in
1094                            :child (make-instance 'button :label "Hi there"))
1095                   :child2 (make-instance 'frame
1096                            :width-request 80 :height-request 60
1097                            :shadow-type :in)))
1098          (vpaned (make-instance 'v-paned
1099                   :border-width 5
1100                   :child1 hpaned
1101                   :child2 (make-instance 'frame
1102                            :width-request 80 :height-request 60
1103                            :shadow-type :in))))
1104
1105     (make-instance 'v-box
1106      :parent window
1107      :child-args '(:expand nil)
1108      :child (list vpaned :expand t)
1109      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1110      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
1111
1112
1113 ;;; Progress bar
1114
1115 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
1116   (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1117          (activity-mode-button (make-instance 'check-button
1118                                 :label "Activity mode"))
1119          (timer (timeout-add 100
1120                  #'(lambda ()
1121                      (if (toggle-button-active-p activity-mode-button)
1122                          (progress-bar-pulse progress)
1123                        (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1124                          (setf
1125                           (progress-bar-fraction progress)
1126                           (if (> fract 1.0)
1127                               0.0
1128                             fract))))
1129                      t))))
1130
1131     (make-instance 'v-box
1132      :parent dialog :border-width 10 :spacing 10
1133      :child progress
1134      :child activity-mode-button)
1135
1136     (signal-connect dialog 'destroy
1137      #'(lambda () (when timer (timeout-remove timer))))))
1138
1139
1140 ;;; Radio buttons
1141
1142 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1143   (make-instance 'v-box
1144    :parent dialog :border-width 10 :spacing 10
1145    :children (make-radio-group 'radio-button
1146               '((:label "button1") (:label "button2") (:label "button3"))
1147               nil)))
1148
1149
1150 ;;; Rangle controls
1151
1152 (define-simple-dialog create-range-controls (dialog "Range controls")
1153   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1154     (make-instance 'v-box
1155      :parent dialog :border-width 10 :spacing 10
1156      :child (make-instance 'h-scale
1157              :width-request 150 :adjustment adjustment :inverted t
1158              :update-policy :delayed :digits 1 :draw-value t)
1159      :child (make-instance 'h-scrollbar
1160              :adjustment adjustment :update-policy :continuous))))
1161
1162
1163 ;;; Reparent test
1164
1165 (define-simple-dialog create-reparent (dialog "Reparent")
1166   (let ((main (make-instance 'h-box
1167                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1168         (label (make-instance 'label :label "Hello World")))
1169
1170     (flet ((create-frame (title)
1171              (let* ((frame (make-instance 'frame :label title :parent main))
1172                     (box (make-instance 'v-box
1173                           :spacing 5 :border-width 5 :parent frame))
1174                     (button (make-instance 'button
1175                              :label "switch" :parent (list box :expand nil))))
1176                (signal-connect button 'clicked
1177                 #'(lambda ()
1178                     (widget-reparent label box)))
1179                box)))
1180
1181       (box-pack-start (create-frame "Frame 1") label nil t 0)
1182       (create-frame "Frame 2"))
1183     (widget-show-all main)))
1184
1185
1186 ;;; Rulers
1187
1188 (define-toplevel create-rulers (window "Rulers"
1189                                 :default-width 300 :default-height 300
1190                                 :events '(:pointer-motion :pointer-motion-hint))
1191   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1192         (h-ruler (make-instance 'h-ruler
1193                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1194                   :position 0.0d0 :max-size 20.0d0))
1195         (v-ruler (make-instance 'v-ruler
1196                   :lower 5.0d0 :upper 15.0d0
1197                   :position 0.0d0 :max-size 20.0d0)))
1198     (signal-connect window 'motion-notify-event
1199      #'(lambda (event)
1200          (widget-event h-ruler event)
1201          (widget-event v-ruler event)))
1202     (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1203     (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1204
1205
1206 ;;; Scrolled window
1207
1208 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1209                                                       :default-width 300
1210                                                       :default-height 300)
1211   (let* ((scrolled-window
1212           (make-instance 'scrolled-window
1213            :parent dialog :border-width 10
1214            :vscrollbar-policy :automatic
1215            :hscrollbar-policy :automatic))
1216          (table
1217           (make-instance 'table
1218            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1219            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1220            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1221
1222       (scrolled-window-add-with-viewport scrolled-window table)
1223       (dotimes (i 20)
1224         (dotimes (j 20)
1225           (let ((button
1226                  (make-instance 'toggle-button
1227                   :label (format nil "button (~D,~D)~%" i j))))
1228             (table-attach table button i (1+ i) j (1+ j)))))
1229       (widget-show-all scrolled-window)))
1230
1231
1232 ;;; Size group
1233
1234 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1235   (let ((size-group (make-instance 'size-group)))
1236     (flet ((create-frame (label rows)
1237              (let ((table (make-instance 'table
1238                            :n-rows (length rows) :n-columns 2 :homogeneous nil
1239                            :row-spacing 5 :column-spacing 10 :border-width 5)))
1240                (loop
1241                 for row in rows
1242                 for i from 0
1243                 do (table-attach table
1244                     (create-label (first row) :xalign 0 :yalign 1)
1245                     0 1 i (1+ i) :x-options '(:expand :fill))
1246                    (let ((combo (make-instance 'combo-box
1247                                  :content (rest row) :active 0)))
1248                      (size-group-add-widget size-group combo)
1249                      (table-attach table combo 1 2 i (1+ i))))
1250                (make-instance 'frame :label label :child table))))
1251
1252       (make-instance 'v-box
1253        :parent dialog :border-width 5 :spacing 5
1254        :child (create-frame "Color Options"
1255                '(("Foreground" "Red" "Green" "Blue")
1256                  ("Background" "Red" "Green" "Blue")))
1257        :child (create-frame "Line Options"
1258                '(("Dashing" "Solid" "Dashed" "Dotted")
1259                  ("Line ends" "Square" "Round" "Arrow")))
1260        :child (create-check-button "Enable grouping"
1261                #'(lambda (active)
1262                    (setf
1263                     (size-group-mode size-group)
1264                     (if active :horizontal :none)))
1265                t)))))
1266
1267
1268 ;;; Shapes
1269
1270 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1271   (let ((window
1272          (make-instance 'window
1273           :type type :default-width 100 :default-height 100
1274           :events '(:button-motion :pointer-motion-hint :button-press)
1275           :signal (list 'destroy destroy))))
1276
1277     (widget-realize window)
1278     (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1279       (let ((fixed (make-instance 'fixed :parent window)))
1280         (fixed-put fixed (create-image-widget source mask) px py))
1281       (widget-shape-combine-mask window mask px py))
1282
1283     (let ((x-offset 0)
1284           (y-offset 0))
1285       (declare (fixnum x-offset y-offset))
1286       (signal-connect window 'button-press-event
1287        #'(lambda (event)
1288            (when (typep event 'gdk:button-press-event)
1289              (setq x-offset (truncate (gdk:event-x event)))
1290              (setq y-offset (truncate (gdk:event-y event)))
1291              (grab-add window)
1292              (gdk:pointer-grab (widget-window window)
1293               :events '(:button-release :button-motion :pointer-motion-hint)
1294               :owner-events t))))
1295
1296       (signal-connect window 'button-release-event
1297        #'(lambda (event)
1298            (declare (ignore event))
1299            (grab-remove window)
1300            (gdk:pointer-ungrab)))
1301
1302       (signal-connect window 'motion-notify-event
1303        #'(lambda (event)
1304            (declare (ignore event))
1305            (multiple-value-bind (win xp yp mask)
1306                (gdk:window-get-pointer root-window)
1307              (declare (ignore mask win) (fixnum xp yp))
1308              (window-move window (- xp x-offset) (- yp y-offset))))))
1309
1310     (window-move window x y)
1311     (widget-show-all window)
1312     window))
1313
1314
1315 (let ((modeller nil)
1316       (sheets nil)
1317       (rings nil))
1318   (defun create-shapes ()
1319     (let ((root-window (gdk:get-root-window)))
1320       (if (not modeller)
1321           (setq
1322            modeller
1323            (create-shape-icon
1324             "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1325             #'(lambda () (setq modeller nil))))
1326         (widget-destroy modeller))
1327
1328       (if (not sheets)
1329           (setq
1330            sheets
1331            (create-shape-icon
1332             "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1333             #'(lambda () (setq sheets nil))))
1334         (widget-destroy sheets))
1335
1336       (if (not rings)
1337           (setq
1338            rings
1339            (create-shape-icon
1340             "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1341             #'(lambda () (setq rings nil))))
1342         (widget-destroy rings)))))
1343
1344
1345
1346 ;;; Spin buttons
1347
1348 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1349   (let ((main (make-instance 'v-box
1350                :spacing 5 :border-width 10 :parent dialog)))
1351
1352     (flet ((create-date-spinner (label adjustment shadow-type)
1353              (declare (ignore shadow-type))
1354              (make-instance 'v-box
1355               :child-args '(:expand nil)
1356               :child (make-instance 'label
1357                       :label label :xalign 0.0 :yalign 0.5)
1358               :child (make-instance 'spin-button
1359                       :adjustment adjustment :wrap t))))
1360       (multiple-value-bind (sec min hour date month year day daylight-p zone)
1361           (get-decoded-time)
1362         (declare (ignore sec min hour day daylight-p zone))
1363         (make-instance 'frame
1364          :label "Not accelerated" :parent main
1365          :child (make-instance 'h-box
1366                  :border-width 10
1367                  :child-args '(:padding 5)
1368                  :child (create-date-spinner "Day : "
1369                          (adjustment-new date 1 31 1 5 0) :out)
1370                  :child (create-date-spinner "Month : "
1371                          (adjustment-new month 1 12 1 5 0) :etched-in)
1372                  :child (create-date-spinner "Year : "
1373                          (adjustment-new year 0 2100 1 100 0) :in)))))
1374
1375     (let ((spinner1 (make-instance 'spin-button
1376                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1377                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1378           (spinner2 (make-instance 'spin-button
1379                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1380                      :climb-rate 1.0 :wrap t))
1381           (value-label (make-instance 'label :label "0")))
1382       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1383        #'(lambda ()
1384            (setf
1385             (spin-button-digits spinner1)
1386             (floor (spin-button-value spinner2)))))
1387
1388       (make-instance 'frame
1389        :label "Accelerated" :parent main
1390        :child (make-instance 'v-box
1391                :border-width 5
1392                :child (list
1393                        (make-instance 'h-box
1394                         :child-args '(:padding 5)
1395                         :child (make-instance 'v-box
1396                                 :child (make-instance 'label
1397                                         :label "Value :"
1398                                         :xalign 0.0 :yalign 0.5)
1399                                 :child spinner1)
1400                         :child (make-instance 'v-box
1401                                 :child (make-instance 'label
1402                                         :label "Digits :"
1403                                         :xalign 0.0 :yalign 0.5)
1404                                 :child spinner2))
1405                        :expand nil :padding 5)
1406                :child (make-instance 'check-button
1407                        :label "Snap to 0.5-ticks" :active t
1408                        :signal (list 'clicked
1409                                 #'(lambda (button)
1410                                     (setf
1411                                      (spin-button-snap-to-ticks-p spinner1)
1412                                      (toggle-button-active-p button)))
1413                                 :object t))
1414                :child (make-instance 'check-button
1415                        :label "Numeric only input mode" :active t
1416                        :signal (list 'clicked
1417                                 #'(lambda (button)
1418                                     (setf
1419                                      (spin-button-numeric-p spinner1)
1420                                      (toggle-button-active-p button)))
1421                                 :object t))
1422                :child value-label
1423                :child (list
1424                        (make-instance 'h-box
1425                         :child-args '(:padding 5)
1426                         :child (make-instance 'button
1427                                 :label "Value as Int"
1428                                 :signal (list 'clicked
1429                                          #'(lambda ()
1430                                              (setf
1431                                               (label-label value-label)
1432                                               (format nil "~D"
1433                                                (spin-button-value-as-int
1434                                                 spinner1))))))
1435                         :child (make-instance 'button
1436                                 :label "Value as Float"
1437                                 :signal (list 'clicked
1438                                          #'(lambda ()
1439                                              (setf
1440                                               (label-label value-label)
1441                                               (format nil
1442                                                (format nil "~~,~DF"
1443                                                 (spin-button-digits spinner1))
1444                                                (spin-button-value spinner1)))))))
1445                        :padding 5 :expand nil))))
1446     (widget-show-all main)))
1447
1448
1449 ;;; Statusbar
1450
1451 (define-toplevel create-statusbar (window "Statusbar")
1452   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1453         (close-button (create-button '("close" :can-default t)
1454                        #'widget-destroy :object window))
1455         (counter 0))
1456
1457     (signal-connect statusbar 'text-popped
1458      #'(lambda (context-id text)
1459          (declare (ignore context-id))
1460          (format nil "Popped: ~A~%" text)))
1461
1462     (make-instance 'v-box
1463      :parent window
1464      :child (make-instance 'v-box
1465              :border-width 10 :spacing 10
1466              :child (create-button "push something"
1467                      #'(lambda ()
1468                          (statusbar-push statusbar 1
1469                           (format nil "something ~D" (incf counter)))))
1470              :child (create-button "pop"
1471                      #'(lambda ()
1472                          (statusbar-pop statusbar 1)))
1473              :child (create-button "steal #4"
1474                      #'(lambda ()
1475                          (statusbar-remove statusbar 1 4)))
1476              :child (create-button "dump stack")
1477              :child (create-button "test contexts"))
1478      :child (list (make-instance 'h-separator) :expand nil)
1479      :child (list
1480              (make-instance 'v-box :border-width 10 :child close-button)
1481              :expand nil)
1482      :child (list statusbar :expand nil))
1483
1484     (widget-grab-focus close-button)))
1485
1486
1487 ;;; Idle test
1488
1489 (define-simple-dialog create-idle-test (dialog "Idle Test")
1490   (let ((label (make-instance 'label
1491                 :label "count: 0" :xpad 10 :ypad 10))
1492         (idle nil)
1493         (count 0))
1494     (signal-connect dialog 'destroy
1495      #'(lambda () (when idle (idle-remove idle))))
1496
1497     (make-instance 'v-box
1498      :parent dialog :border-width 10 :spacing 10
1499      :child label
1500      :child (make-instance 'frame
1501              :label "Label Container" :border-width 5
1502              :child(make-instance 'v-box
1503                    :children (make-radio-group 'radio-button
1504                               '((:label "Resize-Parent" :value :parent :active t)
1505                                 (:label "Resize-Queue" :value :queue)
1506                                 (:label "Resize-Immediate" :value :immediate))
1507                               #'(lambda (mode)
1508                                   (setf
1509                                    (container-resize-mode (dialog-action-area dialog)) mode))))))
1510
1511     (dialog-add-button dialog "Start"
1512      #'(lambda ()
1513          (unless idle
1514            (setq idle
1515             (idle-add
1516              #'(lambda ()
1517                  (incf count)
1518                  (setf (label-label label) (format nil "count: ~D" count))
1519                  t))))))
1520
1521     (dialog-add-button dialog "Stop"
1522      #'(lambda ()
1523          (when idle
1524            (idle-remove idle)
1525            (setq idle nil))))))
1526
1527
1528
1529 ;;; Timeout test
1530
1531 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1532   (let ((label (make-instance 'label
1533                 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1534         (timer nil)
1535         (count 0))
1536     (signal-connect dialog 'destroy
1537      #'(lambda () (when timer (timeout-remove timer))))
1538
1539     (dialog-add-button dialog "Start"
1540      #'(lambda ()
1541          (unless timer
1542            (setq timer
1543             (timeout-add 100
1544              #'(lambda ()
1545                  (incf count)
1546                  (setf (label-label label) (format nil "count: ~D" count))
1547                  t))))))
1548
1549     (dialog-add-button dialog "Stop"
1550      #'(lambda ()
1551          (when timer
1552            (timeout-remove timer)
1553            (setq timer nil))))))
1554
1555
1556 ;;; Text
1557
1558 (define-simple-dialog create-text (dialog "Text" :default-width 400
1559                                                  :default-height 400)
1560   (let* ((text-view (make-instance 'text-view
1561                      :border-width 10 :visible t :wrap-mode :word))
1562          (buffer (text-view-buffer text-view))
1563          (active-tags ()))
1564
1565     (text-buffer-create-tag buffer "Bold" :weight :bold)
1566     (text-buffer-create-tag buffer "Italic" :style :italic)
1567     (text-buffer-create-tag buffer "Underline" :underline :single)
1568
1569     (flet ((create-toggle-callback (tag-name)
1570              (let ((tag (text-tag-table-lookup
1571                          (text-buffer-tag-table buffer) tag-name)))
1572                #'(lambda (active)
1573                    (unless (eq (and (find tag active-tags) t) active)
1574                      ;; user activated
1575                      (if active
1576                          (push tag active-tags)
1577                        (setq active-tags (delete tag active-tags)))
1578                      (multiple-value-bind (non-zero-p start end)
1579                          (text-buffer-get-selection-bounds buffer)
1580                        (declare (ignore non-zero-p))
1581                        (if active
1582                            (text-buffer-apply-tag buffer tag start end)
1583                          (text-buffer-remove-tag buffer tag start end))))))))
1584
1585       (let* ((actions
1586               (make-instance 'action-group
1587                :action (make-instance 'toggle-action
1588                         :name "Bold" :stock-id "gtk-bold" :label "Bold"
1589                         :accelerator "<control>B" :tooltip "Bold"
1590                         :callback (create-toggle-callback "Bold"))
1591                :action (make-instance 'toggle-action
1592                         :name "Italic" :stock-id "gtk-italic" :label "Italic"
1593                         :accelerator "<control>I" :tooltip "Italic"
1594                         :callback (create-toggle-callback "Italic"))
1595                :action (make-instance 'toggle-action
1596                         :name "Underline" :stock-id "gtk-underline"
1597                         :label "Underline" :accelerator "<control>U"
1598                         :tooltip "Underline"
1599                         :callback (create-toggle-callback "Underline"))))
1600              (ui (make-instance 'ui-manager
1601                   :action-group actions
1602                   :ui '((:toolbar "ToolBar"
1603                          (:toolitem "Bold")
1604                          (:toolitem "Italic")
1605                          (:toolitem "Underline"))))))
1606
1607         ;; Callback to activate/deactivate toolbar buttons when cursor
1608         ;; is moved
1609         (signal-connect buffer 'mark-set
1610          #'(lambda (location mark)
1611              (declare (ignore mark))
1612              (text-tag-table-foreach (text-buffer-tag-table buffer)
1613               #'(lambda (tag)
1614                   (let ((active
1615                          (or
1616                           (and
1617                            (text-iter-has-tag-p location tag)
1618                            (not (text-iter-begins-tag-p location tag)))
1619                           (text-iter-ends-tag-p location tag))))
1620                     (unless (eq active (and (find tag active-tags) t))
1621                       (if active
1622                           (push tag active-tags)
1623                         (setq active-tags (delete tag active-tags)))
1624                       (setf
1625                        (toggle-action-active-p
1626                         (action-group-get-action actions (text-tag-name tag)))
1627                        active)))))))
1628
1629         ;; Callback to apply active tags when a character is inserted
1630         (signal-connect buffer 'insert-text
1631          #'(lambda (iter &rest args)
1632              (declare (ignore args))
1633              (let ((before (text-buffer-get-iter-at-offset buffer
1634                             (1- (text-iter-offset iter)))))
1635                (loop
1636                 for tag in active-tags
1637                 do (text-buffer-apply-tag buffer tag before iter))))
1638          :after t)
1639
1640         (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1641         (container-add dialog text-view)
1642
1643         (let ((position (make-instance 'label :visible t)))
1644           (flet ((update-position (line column)
1645                    (setf
1646                     (label-label position)
1647                     (format nil "Cursor Position: ~d,~d" (1+ line) column))))
1648             (update-position 0 0)
1649
1650             ;; Callback to display current position when cursor is moved
1651             (signal-connect buffer 'mark-set
1652              #'(lambda (iter mark)
1653                  (when (and
1654                         (slot-boundp mark 'name)
1655                         (string= (text-mark-name mark) "insert"))
1656                    (update-position
1657                     (text-iter-line iter) (text-iter-line-offset iter)))))
1658
1659             ;; Callback to display current position after the
1660             ;; buffer has been modified
1661             (signal-connect buffer 'changed
1662              #'(lambda ()
1663                  (let ((iter (text-buffer-get-iter-at-insert buffer)))
1664                    (update-position
1665                     (text-iter-line iter) (text-iter-line-offset iter))))
1666              :after t))
1667
1668           (container-add dialog position :expand nil))))))
1669
1670
1671 ;;; Toggle buttons
1672
1673 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1674   (make-instance 'v-box
1675    :border-width 10 :spacing 10 :parent dialog
1676       :children (loop
1677               for n from 1 to 3
1678               collect (make-instance 'toggle-button
1679                        :label (format nil "Button~D" (1+ n))))))
1680
1681
1682
1683 ;;; Toolbar test
1684
1685 (defun create-toolbar (window)
1686   (make-instance 'toolbar
1687    :show-tooltips t :show-arrow nil
1688
1689    ;; Insert a stock item
1690    :child (make-instance 'tool-button
1691            :stock  "gtk-quit"
1692            :tip-text "Destroy toolbar"
1693            :tip-private "Toolbar/Quit"
1694            :signal (list 'clicked #'(lambda () (widget-destroy window))))
1695
1696    :child (make-instance 'separator-tool-item)
1697
1698    :child (make-instance 'tool-button
1699            :label "Horizontal" :stock "gtk-go-forward"
1700            :tip-text "Horizontal toolbar layout"
1701            :tip-private "Toolbar/Horizontal"
1702            :signal (list 'clicked
1703                     #'(lambda (toolbar)
1704                         (setf (toolbar-orientation toolbar) :horizontal))
1705                     :object :parent))
1706
1707    :child (make-instance 'tool-button
1708            :label "Vertical" :stock "gtk-go-down"
1709            :tip-text "Vertical toolbar layout"
1710            :tip-private "Toolbar/Vertical"
1711            :signal (list 'clicked
1712                     #'(lambda (toolbar)
1713                         (setf (toolbar-orientation toolbar) :vertical))
1714                     :object :parent))
1715
1716    :child (make-instance 'separator-tool-item)
1717
1718    :children (make-radio-group 'radio-tool-button
1719               '((:label "Icons" :stock "gtk-justify-left"
1720                  :tip-text "Only show toolbar icons"
1721                  :tip-private "Toolbar/IconsOnly"
1722                  :value :icons)
1723                 (:label "Both" :stock "gtk-justify-center"
1724                  :tip-text "Show toolbar icons and text"
1725                  :tip-private "Toolbar/Both"
1726                  :value :both :active t)
1727                 (:label "Text" :stock "gtk-justify-right"
1728                  :tip-text "Show toolbar text"
1729                  :tip-private "Toolbar/TextOnly"
1730                  :value :text))
1731               (list
1732                #'(lambda (toolbar style)
1733                    (setf (toolbar-style toolbar) style))
1734                :object :parent))
1735
1736    :child (make-instance 'separator-tool-item)
1737
1738    :child (make-instance 'tool-item
1739            :child (make-instance 'entry)
1740            :tip-text "This is an unusable GtkEntry"
1741            :tip-private "Hey don't click me!")
1742
1743    :child (make-instance 'separator-tool-item)
1744
1745    :child (make-instance 'tool-button
1746            :label "Enable" :stock "gtk-add"
1747            :tip-text "Enable tooltips"
1748            :tip-private "Toolbar/EnableTooltips"
1749            :signal (list 'clicked
1750                     #'(lambda (toolbar)
1751                         (setf (toolbar-show-tooltips-p toolbar) t))
1752                     :object :parent))
1753
1754    :child (make-instance 'tool-button
1755            :label "Disable" :stock "gtk-remove"
1756            :tip-text "Disable tooltips"
1757            :tip-private "Toolbar/DisableTooltips"
1758            :signal (list 'clicked
1759                     #'(lambda (toolbar)
1760                         (setf (toolbar-show-tooltips-p toolbar) nil))
1761                     :object :parent))
1762
1763 ;;    :child (make-instance 'separator-tool-item)
1764
1765 ;;    :child (make-instance 'tool-button
1766 ;;         :label "GTK" :icon #p"clg:examples;gtk.png"
1767 ;;         :tip-text "GTK+ Logo"
1768 ;;         :tip-private "Toolbar/GTK+")
1769    ))
1770
1771 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1772   (container-add window (create-toolbar window)))
1773
1774
1775 ;;; Handle box
1776
1777 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1778   (make-instance 'v-box
1779    :parent window
1780    :child (create-label "Above")
1781    :child (make-instance 'h-separator)
1782    :child (make-instance 'h-box
1783            :spacing 10
1784            :child (list
1785                    (make-instance 'handle-box
1786                     :child (create-toolbar window)
1787                     :signal (list 'child-attached
1788                              #'(lambda (child)
1789                                  (format t "~A attached~%" child)))
1790                     :signal (list 'child-detached
1791                              #'(lambda (child)
1792                                  (format t "~A detached~%" child))))
1793                    :expand nil :fill :nil))
1794    :child (make-instance 'h-separator)
1795    :child (create-label "Below")))
1796
1797
1798 ;;; Tooltips test
1799
1800 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1801   (let ((tooltips (make-instance 'tooltips)))
1802     (flet ((create-button (label tip-text tip-private)
1803              (let ((button (make-instance 'toggle-button :label label)))
1804                (tooltips-set-tip tooltips button tip-text tip-private)
1805                button)))
1806       (make-instance 'v-box
1807        :parent dialog :border-width 10 :spacing 10
1808        :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1809        :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")))))
1810
1811
1812 ;;; UI Manager
1813
1814 (defvar *ui-description*
1815   '((:menubar "MenuBar"
1816      (:menu "FileMenu"
1817       (:menuitem "New")
1818       (:menuitem "Open")
1819       (:menuitem "Save")
1820       (:menuitem "SaveAs")
1821       :separator
1822       (:menuitem "Quit"))
1823      (:menu "PreferencesMenu"
1824        (:menu "ColorMenu"
1825         (:menuitem "Red")
1826         (:menuitem "Green")
1827         (:menuitem "Blue"))
1828        (:menu "ShapeMenu"
1829         (:menuitem "Square")
1830         (:menuitem "Rectangle")
1831         (:menuitem "Oval"))
1832        (:menuitem "Bold"))
1833      (:menu "HelpMenu"
1834       (:menuitem "About")))
1835     (:toolbar "ToolBar"
1836      (:toolitem "Open")
1837      (:toolitem "Quit")
1838      :separator
1839      (:toolitem "Logo"))))
1840
1841 (define-toplevel create-ui-manager (window "UI Manager")
1842   (let ((ui (make-instance 'ui-manager)))
1843     (window-add-accel-group window (ui-manager-accel-group ui))
1844     (ui-manager-insert-action-group ui
1845      (make-instance 'action-group :name "Actions"
1846       :action (make-instance 'action :name "FileMenu" :label "_File")
1847       :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
1848       :action (make-instance 'action :name "ColorMenu" :label "_Color")
1849       :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
1850       :action (make-instance 'action :name "HelpMenu" :label "_Help")
1851       :action (make-instance 'action
1852                :name "New" :stock-id "gtk-new" :label "_New"
1853                :accelerator "<control>N" :tooltip "Create a new file")
1854       :action (make-instance 'action
1855                :name "Open" :stock-id "gtk-open" :label "_Open"
1856                :accelerator "<control>O" :tooltip "Open a file"
1857                :callback #'create-file-chooser)
1858       :action (make-instance 'action
1859                :name "Save" :stock-id "gtk-save" :label "_Save"
1860                :accelerator "<control>S" :tooltip "Save current file")
1861       :action (make-instance 'action
1862                :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
1863                :tooltip "Save to a file")
1864       :action (make-instance 'action
1865                :name "Quit" :stock-id "gtk-quit" :label "_Quit"
1866                :accelerator "<control>Q" :tooltip "Quit"
1867                :callback (list #'widget-destroy :object window))
1868       :action (make-instance 'action
1869                :name "About" :label "_About"
1870                :accelerator "<control>A" :tooltip "About")
1871       :action (make-instance 'action
1872                :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
1873       :action (make-instance 'toggle-action
1874                :name "Bold" :stock-id "gtk-bold" :label "_Bold"
1875                :accelerator "<control>B" :tooltip "Bold" :active t)
1876       :actions (make-radio-group 'radio-action
1877                 '((:name "Red" :value :red :label "_Red"
1878                    :accelerator "<control>R" :tooltip "Blood")
1879                   (:name "Green" :value :green :label "_Green"
1880                    :accelerator "<control>G" :tooltip "Grass" :active t)
1881                   (:name "Blue" :value :blue :label "_Blue"
1882                    :accelerator "<control>B" :tooltip "Sky"))
1883                 #'(lambda (active) (print active)))
1884       :actions (make-radio-group 'radio-action
1885                 '((:name "Square" :value :square :label "_Square"
1886                    :accelerator "<control>S" :tooltip "Square")
1887                   (:name "Rectangle" :value :rectangle :label "_Rectangle"
1888                    :accelerator "<control>R" :tooltip "Rectangle")
1889                   (:name "Oval" :value :oval :label "_Oval"
1890                    :accelerator "<control>O" :tooltip "Egg"))
1891                 #'(lambda (active) (print active)))))
1892
1893     (ui-manager-add-ui ui *ui-description*)
1894
1895     (make-instance 'v-box
1896      :parent window
1897      :child (list
1898              (ui-manager-get-widget ui "/MenuBar")
1899              :expand nil :fill nil)
1900      :child (list
1901              (ui-manager-get-widget ui "/ToolBar")
1902              :expand nil :fill nil)
1903      :child (make-instance 'label
1904              :label "Type Ctrl+Q to quit"
1905              :xalign 0.5 :yalign 0.5
1906              :width-request 200 :height-request 200))))
1907
1908
1909
1910 ;;; Main window
1911
1912 (defun create-main-window (&optional display)
1913   (let* ((button-specs
1914           '(("button box" create-button-box)
1915             ("buttons" create-buttons)
1916             ("calendar" create-calendar)
1917             ("check buttons" create-check-buttons)
1918             ("color selection" create-color-selection)
1919             ("cursors" create-cursors)
1920             ("dialog" create-dialog)
1921             ("entry" create-entry)
1922             ("enxpander" create-expander)
1923             ("file chooser" create-file-chooser)
1924             ("font selection" create-font-selection)
1925             ("handle box" create-handle-box)
1926             #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
1927             ("icon view" create-icon-view)
1928             ("image" create-image)
1929             ("labels" create-labels)
1930             ("layout" create-layout)
1931             ("list" create-list)
1932             ("menus" create-menus)
1933 ;;          ("modal window")
1934             ("notebook" create-notebook)
1935             ("panes" create-panes)
1936             ("progress bar" create-progress-bar)
1937             ("radio buttons" create-radio-buttons)
1938             ("range controls" create-range-controls)
1939 ;;          ("rc file")
1940             ("reparent" create-reparent)
1941             ("rulers" create-rulers)
1942 ;;          ("saved position")
1943             ("scrolled windows" create-scrolled-windows)
1944             ("size group" create-size-group)
1945             ("shapes" create-shapes)
1946             ("spinbutton" create-spins)
1947             ("statusbar" create-statusbar)
1948             ("test idle" create-idle-test)
1949             ("test timeout" create-timeout-test)
1950             ("text" create-text)
1951             ("toggle buttons" create-toggle-buttons)
1952             ("toolbar" create-toolbar-window)
1953             ("tooltips" create-tooltips)
1954             ("UI manager" create-ui-manager)))
1955
1956          (main-window (make-instance 'window
1957                        :display display
1958                        :title "testgtk.lisp" :name "main_window"
1959                        :default-width 200 :default-height 400
1960                        :allow-grow t :allow-shrink nil))
1961          (scrolled-window (make-instance 'scrolled-window
1962                            :hscrollbar-policy :automatic
1963                            :vscrollbar-policy :automatic
1964                            :border-width 10))
1965          (close-button (make-instance 'button
1966                         :stock "gtk-close" :can-default t
1967                         :signal (list 'clicked #'widget-destroy :object main-window))))
1968
1969     (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1970       (setf
1971        (window-icon main-window)
1972        (gdk:pixbuf-add-alpha icon t 254 254 252)))
1973
1974     ;; Main box
1975     (make-instance 'v-box
1976      :parent main-window
1977      :child-args '(:expand nil)
1978      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1979      :child (list (make-instance 'label :label (clg-version)) :fill nil)
1980      :child (list (make-instance 'label
1981                    :label #-cmu
1982                           (format nil "~A (~A)"
1983                            (lisp-implementation-type)
1984                            #-clisp
1985                            (lisp-implementation-version)
1986                            #+clisp
1987                            (let ((version (lisp-implementation-version)))
1988                              (subseq version 0 (position #\sp version))))
1989                           ;; The version string in CMUCL is far too long
1990                           #+cmu(lisp-implementation-type))
1991                   :fill nil)
1992      :child (list scrolled-window :expand t)
1993      :child (make-instance 'h-separator)
1994      :child (make-instance 'v-box
1995              :homogeneous nil :spacing 10 :border-width 10
1996              :child close-button))
1997
1998     (let ((content-box
1999            (make-instance 'v-box
2000             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
2001             :children (mapcar #'(lambda (spec)
2002                                   (apply #'create-button spec))
2003                        button-specs))))
2004       (scrolled-window-add-with-viewport scrolled-window content-box))
2005
2006     (widget-grab-focus close-button)
2007     (widget-show-all main-window)
2008     main-window))
2009
2010 (clg-init)
2011 (within-main-loop (create-main-window))