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