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

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