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.1 2000-08-14 16:44:26 espen Exp $
  19
  20
  21 (use-package "GTK")
  22
  23 (defmacro define-test-window (name title &body body)
  24   `(let ((window nil))
  25      (defun ,name ()
  26        (unless window
  27          (setq window (window-new :toplevel))
  28          (signal-connect
  29           window 'destroy #'(lambda () (widget-destroyed window)))
  30          (setf (window-title window) ,title)
  31          (setf (container-border-width window) 0)
  32          ,@body)
  33
  34        (if (not (widget-visible-p window))
  35            (widget-show-all window)
  36            (widget-destroy window)))))
  37
  38
  39 (defmacro define-test-dialog (name title &body body)
  40   `(let ((window nil))
  41      (defun ,name ()
  42        (unless window
  43          (setq window (dialog-new))
  44          (signal-connect
  45           window 'destroy #'(lambda () (widget-destroyed window)))
  46          (setf (window-title window) ,title)
  47          (setf (container-border-width window) 0)
  48          (let ((main-box (vbox-new nil 0))
  49                (action-area (dialog-action-area window)))
  50            (box-pack-start (dialog-vbox window) main-box t t 0)
  51            ,@body))
  52
  53        (if (not (widget-visible-p window))
  54            (widget-show-all window)
  55          (widget-destroy window)))))
  56
  57
  58 (defmacro define-standard-dialog (name title &body body)
  59   `(define-test-dialog ,name ,title
  60      (let ((close-button (button-new "close")))
  61        (signal-connect close-button 'clicked #'widget-destroy :object window)
  62        (setf (widget-can-default-p close-button) t)
  63        (box-pack-start action-area close-button t t 0)
  64        (widget-grab-default close-button)
  65        ,@body)))
  66
  67
  68 (defun build-option-menu (items history)
  69   (let ((option-menu (option-menu-new))
  70         (menu (menu-new)))
  71     (labels ((create-menu (items i group)
  72                (when items
  73                  (let* ((item (first items))
  74                         (menu-item (radio-menu-item-new group (first item))))
  75                    (signal-connect
  76                     menu-item 'activate
  77                     #'(lambda ()
  78                         (when (widget-mapped-p menu-item)
  79                           (funcall (second item)))))
  80
  81                    (menu-append menu menu-item)
  82                    (when (= i history)
  83                      (setf (check-menu-item-active-p menu-item) t))
  84                    (widget-show menu-item)
  85                    (create-menu
  86                     (rest items) (1+ i) (radio-menu-item-group menu-item))))))
  87       (create-menu items 0 nil))
  88     (setf (option-menu-menu option-menu) menu)
  89     (setf (option-menu-history option-menu) history)
  90     option-menu))
  91
  92
  93
  94 ;;; Pixmaps used in some of the tests
  95
  96 (defvar gtk-mini-xpm
  97   '("15 20 17 1"
  98     "       c None"
  99     ".      c #14121F"
 100     "+      c #278828"
 101     "@      c #9B3334"
 102     "#      c #284C72"
 103     "$      c #24692A"
 104     "%      c #69282E"
 105     "&      c #37C539"
 106     "*      c #1D2F4D"
 107     "=      c #6D7076"
 108     "-      c #7D8482"
 109     ";      c #E24A49"
 110     ">      c #515357"
 111     ",      c #9B9C9B"
 112     "'      c #2FA232"
 113     ")      c #3CE23D"
 114     "!      c #3B6CCB"
 115     "               "
 116     "      ***>     "
 117     "    >.*!!!*    "
 118     "   ***....#*=  "
 119     "  *!*.!!!**!!# "
 120     " .!!#*!#*!!!!# "
 121     " @%#!.##.*!!$& "
 122     " @;%*!*.#!#')) "
 123     " @;;@%!!*$&)'' "
 124     " @%.%@%$'&)$+' "
 125     " @;...@$'*'*)+ "
 126     " @;%..@$+*.')$ "
 127     " @;%%;;$+..$)# "
 128     " @;%%;@$$$'.$# "
 129     " %;@@;;$$+))&* "
 130     "  %;;;@+$&)&*  "
 131     "   %;;@'))+>   "
 132     "    %;@'&#     "
 133     "     >%$$      "
 134     "      >=       "))
 135
 136 (defvar book-closed-xpm
 137   '("16 16 6 1"
 138     "       c None s None"
 139     ".      c black"
 140     "X      c red"
 141     "o      c yellow"
 142     "O      c #808080"
 143     "#      c white"
 144     "                "
 145     "       ..       "
 146     "     ..XX.      "
 147     "   ..XXXXX.     "
 148     " ..XXXXXXXX.    "
 149     ".ooXXXXXXXXX.   "
 150     "..ooXXXXXXXXX.  "
 151     ".X.ooXXXXXXXXX. "
 152     ".XX.ooXXXXXX..  "
 153     " .XX.ooXXX..#O  "
 154     "  .XX.oo..##OO. "
 155     "   .XX..##OO..  "
 156     "    .X.#OO..    "
 157     "     ..O..      "
 158     "      ..        "
 159     "                "))
 160
 161 (defvar mini-page-xpm
 162   '("16 16 4 1"
 163     "       c None s None"
 164     ".      c black"
 165     "X      c white"
 166     "o      c #808080"
 167     "                "
 168     "   .......      "
 169     "   .XXXXX..     "
 170     "   .XoooX.X.    "
 171     "   .XXXXX....   "
 172     "   .XooooXoo.o  "
 173     "   .XXXXXXXX.o  "
 174     "   .XooooooX.o  "
 175     "   .XXXXXXXX.o  "
 176     "   .XooooooX.o  "
 177     "   .XXXXXXXX.o  "
 178     "   .XooooooX.o  "
 179     "   .XXXXXXXX.o  "
 180     "   ..........o  "
 181     "    oooooooooo  "
 182     "                "))
 183
 184 (defvar book-open-xpm
 185   '("16 16 4 1"
 186     "       c None s None"
 187     ".      c black"
 188     "X      c #808080"
 189     "o      c white"
 190     "                "
 191     "  ..            "
 192     " .Xo.    ...    "
 193     " .Xoo. ..oo.    "
 194     " .Xooo.Xooo...  "
 195     " .Xooo.oooo.X.  "
 196     " .Xooo.Xooo.X.  "
 197     " .Xooo.oooo.X.  "
 198     " .Xooo.Xooo.X.  "
 199     " .Xooo.oooo.X.  "
 200     "  .Xoo.Xoo..X.  "
 201     "   .Xo.o..ooX.  "
 202     "    .X..XXXXX.  "
 203     "    ..X.......  "
 204     "     ..         "
 205     "                "))
 206
 207
 208
 209 ;;; Button box
 210
 211 (defun create-bbox (class title spacing child-w child-h layout)
 212   (let* ((frame (make-instance 'frame :title title))
 213          (bbox (make-instance 'class
 214                 :border-width 5
 215                 :layout layout
 216                 :spacing spacing
 217                 :childrent
 218                 (list
 219                  (make-instance 'button :label "OK")
 220                  (make-instance 'button :label "Cancel")
 221                  (make-instance 'button :label "Help"))
 222                 :parent frame)))
 223     (setf (button-box-child-size bbox) (vector child-w child-h))
 224     frame))
 225
 226
 227 (define-test-window create-button-box "Button Boxes"
 228   (setf (container-border-width window) 10)
 229   (let ((main-box (vbox-new nil 0)))
 230     (let ((frame (frame-new "Horizontal Button Boxes"))
 231           (box (vbox-new nil 0)))
 232       (container-add window main-box)
 233       (box-pack-start main-box frame t t 10)
 234       (setf (container-border-width box) 10)
 235       (container-add frame box)
 236       (box-pack-start
 237        box (create-bbox #'hbutton-box-new "Spread" 40 85 20 :spread) t t 0)
 238       (box-pack-start
 239        box (create-bbox #'hbutton-box-new "Edge" 40 85 20 :edge) t t 0)
 240       (box-pack-start
 241        box (create-bbox #'hbutton-box-new "Start" 40 85 20 :start) t t 0)
 242       (box-pack-start
 243        box (create-bbox #'hbutton-box-new "End" 40 85 20 :end) t t 0))
 244
 245     (let ((frame (frame-new "Vertical Button Boxes"))
 246           (box (hbox-new nil 0)))
 247       (box-pack-start main-box frame t t 10)
 248       (setf (container-border-width box) 10)
 249       (container-add frame box)
 250       (box-pack-start
 251        box (create-bbox #'vbutton-box-new "Spread" 30 85 20 :spread) t t 5)
 252       (box-pack-start
 253        box (create-bbox #'vbutton-box-new "Edge" 30 85 20 :edge) t t 5)
 254       (box-pack-start
 255        box (create-bbox #'vbutton-box-new "Start" 30 85 20 :start) t t 5)
 256       (box-pack-start
 257        box (create-bbox #'vbutton-box-new "End" 30 85 20 :end) t t 5))))
 258
 259
 260
 261 (define-standard-dialog create-buttons "Buttons"
 262   (let ((table (table-new 3 3 nil))
 263         (buttons `((,(button-new "button1") 0 1 0 1)
 264                    (,(button-new "button2") 1 2 1 2)
 265                    (,(button-new "button3") 2 3 2 3)
 266                    (,(button-new "button4") 0 1 2 3)
 267                    (,(button-new "button5") 2 3 0 1)
 268                    (,(button-new "button6") 1 2 2 3)
 269                    (,(button-new "button7") 1 2 0 1)
 270                    (,(button-new "button8") 2 3 1 2)
 271                    (,(button-new "button9") 0 1 1 2))))
 272     (setf (table-row-spacings table) 5)
 273     (setf (table-column-spacings table) 5)
 274     (setf (container-border-width table) 10)
 275     (box-pack-start main-box table t t 0)
 276     (do ((tmp buttons (rest tmp)))
 277         ((endp tmp))
 278       (let ((button (first tmp))
 279             (widget (or (first (second tmp))
 280                         (first (first buttons)))))
 281         (signal-connect (first button) 'clicked
 282          #'(lambda ()
 283              (if (widget-visible-p widget)
 284                  (widget-hide widget)
 285                (widget-show widget))))
 286         (apply #'table-attach table button)))))
 287
 288
 289 ;; Calenadar
 290
 291 (define-standard-dialog create-calendar "Calendar"
 292   (setf (container-border-width main-box) 10)
 293   (box-pack-start main-box (calendar-new) t t 0))
 294
 295
 296
 297 ;;; Check buttons
 298
 299 (define-standard-dialog create-check-buttons "GtkCheckButton"
 300   (setf (container-border-width main-box) 10)
 301   (setf (box-spacing main-box) 10)
 302   (box-pack-start main-box (check-button-new "button1") t t 0)
 303   (box-pack-start main-box (check-button-new "button2") t t 0)
 304   (box-pack-start main-box (check-button-new "button3") t t 0))
 305
 306
 307
 308 ;;; CList
 309
 310 (let ((style1 nil)
 311       (style2 nil)
 312       (style3 nil))
 313   (defun insert-row-clist (clist)
 314     (let* ((text '("This" "is" "an" "inserted" "row"
 315                    "This" "is" "an" "inserted" "row"
 316                    "This" "is" "an" "inserted" "row"
 317                    "This" "is" "an" "inserted" "row"))
 318            (row
 319             (if (clist-focus-row clist)
 320                 (clist-insert clist (clist-focus-row clist) text)
 321               (clist-prepend clist text))))
 322
 323       (unless style1
 324         (let ((color1 '#(0 56000 0))
 325               (color2 '#(32000 0 56000)))
 326           (setq style1 (style-copy (widget-style clist)))
 327           (setf
 328            (style-base style1 :normal) color1
 329            (style-base style1 :selected) color2)
 330
 331           (setq style2 (style-copy (widget-style clist)))
 332           (setf
 333            (style-fg style2 :normal) color1
 334            (style-fg style2 :selected) color2)
 335
 336           (setq style3 (style-copy (widget-style clist)))
 337           (setf
 338            (style-fg style3 :normal) color1
 339            (style-base style3 :normal) color2
 340            (style-font style3) "-*-courier-medium-*-*-*-*-120-*-*-*-*-*-*")))
 341
 342       (setf (clist-cell-style clist row 3) style1)
 343       (setf (clist-cell-style clist row 4) style2)
 344       (setf (clist-cell-style clist row 0) style3))))
 345
 346
 347 (define-standard-dialog create-clist "clist"
 348   (let* ((titles '("auto resize" "not resizeable" "max width 100"
 349                    "min width 50" "hide column" "Title 5" "Title 6"
 350                    "Title 7" "Title 8"  "Title 9"  "Title 10"
 351                    "Title 11" "Title 12" "Title 13" "Title 14"
 352                    "Title 15" "Title 16" "Title 17" "Title 18"
 353                    "Title 19"))
 354          (clist (clist-new titles))
 355          (scrolled-window (scrolled-window-new nil nil)))
 356
 357     (setf (container-border-width scrolled-window) 5)
 358     (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
 359     (container-add scrolled-window clist)
 360
 361     (signal-connect
 362      clist 'click-column
 363      #'(lambda (column)
 364          (cond
 365           ((= column 4)
 366            (setf (clist-column-visible-p clist column) nil))
 367           ((= column (clist-sort-column clist))
 368            (if (eq (clist-sort-type clist) :ascending)
 369                (setf (clist-sort-type clist) :descending)
 370              (setf (clist-sort-type clist) :ascending)))
 371           (t
 372            (setf (clist-sort-column clist) column)))
 373          (clist-sort clist)))
 374
 375     (let ((box2 (hbox-new nil 5)))
 376       (setf (container-border-width box2) 5)
 377       (box-pack-start main-box box2 nil nil 0)
 378
 379       (let ((button (button-new "Insert Row")))
 380         (box-pack-start box2 button t t 0)
 381         (signal-connect
 382          button 'clicked #'insert-row-clist :object clist))
 383
 384       (let ((button (button-new "Add 1,000 Rows With Pixmaps")))
 385         (box-pack-start box2 button t t 0)
 386         (signal-connect
 387          button 'clicked
 388          #'(lambda ()
 389              (multiple-value-bind (pixmap mask)
 390                  (gdk:pixmap-create gtk-mini-xpm)
 391                (let ((texts (do ((i 4 (1+ i))
 392                                  (texts '(nil "Center" "Right")))
 393                                 ((= i (length titles)) (reverse texts))
 394                               (push (format nil "Column ~D" i) texts))))
 395                  (clist-freeze clist)
 396                  (dotimes (i 1000)
 397                    (let ((row
 398                           (clist-append
 399                            clist
 400                            (cons (format nil "CListRow ~D" (random 1000))
 401                                  texts))))
 402                      (clist-set-cell-pixtext
 403                       clist row 3 "gtk+" 5 (list pixmap mask))))
 404                  (clist-thaw clist))))))
 405
 406       (let ((button (button-new "Add 10,000 Rows")))
 407         (box-pack-start box2 button t t 0)
 408         (signal-connect
 409          button 'clicked
 410          #'(lambda ()
 411              (let ((texts (do ((i 3 (1+ i))
 412                                (texts '("Center" "Right")))
 413                               ((= i (length titles)) (reverse texts))
 414                             (push (format nil "Column ~D" i) texts))))
 415                (clist-freeze clist)
 416                (dotimes (i 10000)
 417                  (clist-append
 418                   clist (cons (format nil "CListRow ~D" (random 1000)) texts)))
 419                (clist-thaw clist))))))
 420
 421
 422     (let ((box2 (hbox-new nil 5)))
 423       (setf (container-border-width box2) 5)
 424       (box-pack-start main-box box2 nil nil 0)
 425
 426       (let ((button (button-new "Clear List")))
 427         (box-pack-start box2 button t t 0)
 428         (signal-connect
 429          button 'clicked
 430          #'(lambda ()
 431              (clist-clear clist))))
 432
 433       (let ((button (button-new "Remove Selection")))
 434         (box-pack-start box2 button t t 0)
 435         (signal-connect
 436          button 'clicked
 437          #'(lambda ()
 438              (clist-freeze clist)
 439              (let ((selection-mode (clist-selection-mode clist)))
 440                (labels ((remove-selection ()
 441                           (let ((selection (clist-selection clist)))
 442                             (when selection
 443                               (clist-remove clist (first selection))
 444                               (unless (eq selection-mode :browse)
 445                                 (remove-selection))))))
 446                  (remove-selection))
 447
 448                (when (and
 449                       (eq selection-mode :extended)
 450                       (not (clist-selection clist))
 451                       (clist-focus-row clist))
 452                  (clist-select-row clist (clist-focus-row clist))))
 453              (clist-thaw clist))))
 454
 455       (let ((button (button-new "Undo Selection")))
 456         (box-pack-start box2 button t t 0)
 457         (signal-connect
 458          button 'clicked #'clist-undo-selection :object clist))
 459
 460       (let ((button (button-new "Warning Test")))
 461         (box-pack-start box2 button t t 0)
 462         (signal-connect button 'clicked #'(lambda ()))))
 463
 464
 465     (let ((box2 (hbox-new nil 5)))
 466       (setf (container-border-width box2) 5)
 467       (box-pack-start main-box box2 nil nil 0)
 468
 469       (let ((button (check-button-new "Show Title Buttons")))
 470         (box-pack-start box2 button t t 0)
 471         (signal-connect
 472          button 'clicked
 473          #'(lambda ()
 474              (if (toggle-button-active-p button)
 475                  (clist-column-titles-show clist)
 476                (clist-column-titles-hide clist))))
 477         (setf (toggle-button-active-p button) t))
 478
 479       (let ((button (check-button-new "Reorderable")))
 480         (box-pack-start box2 button nil t 0)
 481         (signal-connect
 482          button 'clicked
 483          #'(lambda ()
 484              (setf
 485               (clist-reorderable-p clist) (toggle-button-active-p button))))
 486         (setf (toggle-button-active-p button) t))
 487
 488       (box-pack-start box2 (label-new "Selection Mode : ") nil t 0)
 489       (let ((option-menu
 490              (build-option-menu
 491               `(("Single"
 492                  ,#'(lambda () (setf (clist-selection-mode clist) :single)))
 493                 ("Browse"
 494                  ,#'(lambda () (setf (clist-selection-mode clist) :browse)))
 495                 ("Multiple"
 496                  ,#'(lambda () (setf (clist-selection-mode clist) :multiple)))
 497                 ("Extended"
 498                  ,#'(lambda () (setf (clist-selection-mode clist) :extended))))
 499               3)))
 500         (box-pack-start box2 option-menu nil t 0)))
 501
 502     (box-pack-start main-box scrolled-window t t 0)
 503     (setf (clist-row-height clist) 18)
 504     (setf (widget-height clist) 300)
 505
 506     (dotimes (i (length titles))
 507       (setf (clist-column-width clist i) 80))
 508
 509     (setf (clist-column-auto-resize-p clist 0) t)
 510     (setf (clist-column-resizeable-p clist 1) nil)
 511     (setf (clist-column-max-width clist 2) 100)
 512     (setf (clist-column-min-width clist 3) 50)
 513     (setf (clist-selection-mode clist) :extended)
 514     (setf (clist-column-justification clist 1) :right)
 515     (setf (clist-column-justification clist 2) :center)
 516
 517     (let ((style (style-new))
 518           (texts (do ((i 3 (1+ i))
 519                       (texts '("Center" "Right")))
 520                      ((= i (length titles)) (reverse texts))
 521                      (push (format nil "Column ~D" i) texts))))
 522        (setf
 523         (style-font style) "-adobe-helvetica-bold-r-*-*-*-140-*-*-*-*-*-*"
 524         (style-fg style :normal) '#(56000 0 0)
 525         (style-base style :normal) '#(0 56000 32000))
 526
 527       (dotimes (i 10)
 528         (clist-append clist (cons (format nil "CListRow ~D" i) texts))
 529         (if (= (mod i 4) 2)
 530             (setf (clist-row-style clist i) style)
 531           (setf (clist-cell-style clist i (mod i 4)) style))))))
 532
 533
 534
 535 ;;; Color selection
 536
 537 (let ((color-dialog nil))
 538   (defun create-color-selection ()
 539     (unless color-dialog
 540       (setq color-dialog
 541             (color-selection-dialog-new "color selection dialog"))
 542
 543       (setf (window-position color-dialog) :mouse)
 544       (signal-connect
 545        color-dialog 'destroy #'(lambda () (widget-destroyed color-dialog)))
 546
 547       (let ((colorsel (color-selection-dialog-colorsel color-dialog)))
 548         (setf (color-selection-use-opacity-p colorsel) t)
 549         (setf (color-selection-policy colorsel) :continuous)
 550
 551 ;       (signal-connect colorsel 'color-changed #'(lambda () nil))
 552
 553         (let ((button (color-selection-dialog-ok-button color-dialog)))
 554           (signal-connect
 555            button 'clicked
 556            #'(lambda ()
 557                (let ((color (color-selection-color colorsel)))
 558                  (format t "Selected color: ~A~%" color)
 559                  (setf (color-selection-color colorsel) color))))))
 560
 561       (let ((button (color-selection-dialog-cancel-button color-dialog)))
 562         (signal-connect
 563          button 'clicked #'widget-destroy :object color-dialog)))
 564
 565     (if (not (widget-visible-p color-dialog))
 566         (widget-show-all color-dialog)
 567       (widget-destroy color-dialog))))
 568
 569
 570
 571 ;;; CTree
 572
 573 (let ((total-pages 0)
 574       (total-books 0)
 575       (status-labels)
 576       (style1)
 577       (style2)
 578       (pixmap1)
 579       (pixmap2)
 580       (pixmap3))
 581
 582   (defun after-press (ctree &rest data)
 583     (declare (ignore data))
 584     (setf
 585      (label-text (svref status-labels 0))
 586      (format nil "~D" total-books))
 587     (setf
 588      (label-text (svref status-labels 1))
 589      (format nil "~D" total-pages))
 590     (setf
 591      (label-text (svref status-labels 2))
 592      (format nil "~D" (length (clist-selection ctree))))
 593     (setf
 594      (label-text (svref status-labels 3))
 595      (format nil "~D" (clist-n-rows ctree)))
 596     nil)
 597
 598   (defun build-recursive (ctree parent current-depth depth books pages)
 599     (let ((sibling nil))
 600       (do ((i (+ pages books) (1- i)))
 601           ((= i books))
 602         (declare (fixnum i))
 603         (incf total-pages)
 604         (setq
 605          sibling
 606          (ctree-insert-node
 607           ctree parent sibling
 608           (list
 609            (format nil "Page ~D" (random 100))
 610            (format nil "Item ~D-~D" current-depth i))
 611           5 :pixmap pixmap3 :leaf t))
 612         (when (and parent (eq (ctree-line-style ctree) :tabbed))
 613           (setf
 614            (ctree-row-style ctree sibling)
 615            (ctree-row-style ctree parent))))
 616
 617       (unless (= current-depth depth)
 618         (do ((i books (1- i)))
 619             ((zerop i))
 620           (incf total-books)
 621           (setq
 622            sibling
 623            (ctree-insert-node
 624             ctree parent sibling
 625             (list
 626              (format nil "Book ~D" (random 100))
 627              (format nil "Item ~D-~D" current-depth i))
 628             5 :closed pixmap1 :opened pixmap2))
 629
 630           (let ((style (style-new))
 631                 (color (case (mod current-depth 3)
 632                          (0 (vector
 633                              (* 10000 (mod current-depth 6))
 634                              0
 635                              (- 65535 (mod (* i 10000) 65535))))
 636                          (1 (vector
 637                              (* 10000 (mod current-depth 6))
 638                              (- 65535 (mod (* i 10000) 65535))
 639                              0))
 640                          (t (vector
 641                              (- 65535 (mod (* i 10000) 65535))
 642                              0
 643                              (* 10000 (mod current-depth 6)))))))
 644             (setf (style-base style :normal) color)
 645             (ctree-set-node-data ctree sibling style #'style-unref)
 646
 647             (when (eq (ctree-line-style ctree) :tabbed)
 648               (setf (ctree-row-style ctree sibling) style)))
 649
 650           (build-recursive
 651            ctree sibling (1+ current-depth)  depth books pages)))))
 652
 653   (defun rebuild-tree (ctree depth books pages)
 654     (let ((n (* (/ (1- (expt books depth)) (1- books)) (1+ pages))))
 655       (if (> n 10000)
 656           (format t "~D total items? Try less~%" n)
 657         (progn
 658           (clist-freeze ctree)
 659           (clist-clear ctree)
 660           (setq total-books 1)
 661           (setq total-pages 0)
 662           (let ((parent
 663                  (ctree-insert-node
 664                   ctree nil nil '("Root") 5
 665                   :closed pixmap1 :opened pixmap2 :expanded t))
 666                 (style (style-new)))
 667             (setf (style-base style :normal) '#(0 45000 55000))
 668             (ctree-set-node-data ctree parent style #'style-unref)
 669
 670             (when (eq (ctree-line-style ctree) :tabbed)
 671               (setf (ctree-row-style ctree parent) style))
 672
 673             (build-recursive ctree parent 1 depth books pages)
 674             (clist-thaw ctree)
 675             (after-press ctree))))))
 676
 677   (let ((export-window)
 678         (export-ctree))
 679     (defun export-tree (ctree)
 680       (unless export-window
 681         (setq export-window (window-new :toplevel))
 682         (signal-connect
 683          export-window 'destroy
 684          #'(lambda ()
 685              (widget-destroyed export-window)))
 686
 687         (setf (window-title export-window) "Exported ctree")
 688         (setf (container-border-width export-window) 5)
 689
 690         (let ((vbox (vbox-new nil 0)))
 691           (container-add export-window vbox)
 692
 693           (let ((button (button-new "Close")))
 694             (box-pack-end vbox button nil t 0)
 695             (signal-connect
 696              button 'clicked #'widget-destroy :object export-window))
 697
 698           (box-pack-end vbox (hseparator-new) nil t 10)
 699
 700           (setq export-ctree (ctree-new '("Tree" "Info")))
 701           (setf (ctree-line-style export-ctree) :dotted)
 702
 703           (let ((scrolled-window (scrolled-window-new)))
 704             (container-add scrolled-window export-ctree)
 705             (setf
 706              (scrolled-window-scrollbar-policy scrolled-window) :automatic)
 707             (box-pack vbox scrolled-window)
 708             (setf (clist-selection-mode export-ctree) :extended)
 709             (setf (clist-column-width export-ctree 0) 200)
 710             (setf (clist-column-width export-ctree 1) 200)
 711             (setf (widget-width export-ctree) 300)
 712             (setf (widget-height export-ctree) 200))))
 713
 714       (unless (widget-visible-p export-window)
 715         (widget-show-all export-window))
 716
 717       (clist-clear export-ctree)
 718       (let ((node (ctree-nth-node ctree (clist-focus-row ctree))))
 719         (when node
 720           (let ((tree-list
 721                  (list (ctree-map-to-list ctree node #'(lambda (node) node)))))
 722             (ctree-insert-from-list
 723              export-ctree nil tree-list
 724              #'(lambda (export-ctree-node ctree-node)
 725                  (multiple-value-bind
 726                      (text spacing pixmap-closed bitmap-closed pixmap-opened
 727                       bitmap-opened leaf expanded)
 728                      (ctree-node-info ctree ctree-node)
 729                    (ctree-set-node-info
 730                     export-ctree export-ctree-node text spacing
 731                     :closed (list pixmap-closed bitmap-closed)
 732                     :opened (list pixmap-opened bitmap-opened)
 733                     :leaf leaf :expanded expanded))
 734                  (unless (eq (ctree-cell-type ctree ctree-node 1) :empty)
 735                    (setf
 736                     (ctree-cell-text export-ctree export-ctree-node 1)
 737                     (ctree-cell-text ctree ctree-node 1))))))))))
 738
 739
 740   (define-test-window create-ctree "CTree"
 741     (let ((vbox (vbox-new nil 0))
 742           (ctree (ctree-new '("Tree" "Info"))))
 743
 744       (container-add window vbox)
 745
 746       (let ((hbox (hbox-new nil 5)))
 747         (setf (container-border-width hbox) 5)
 748         (box-pack-start vbox hbox nil t 0)
 749
 750         (let ((spin1 (spin-button-new (adjustment-new 4 1 10 1 5 0) 0 0))
 751               (spin2 (spin-button-new (adjustment-new 3 1 20 1 5 0) 0 0))
 752               (spin3 (spin-button-new (adjustment-new 5 1 20 1 5 0) 0 0)))
 753
 754           (box-pack-start hbox (label-new "Depth :") nil t 0)
 755           (box-pack-start hbox spin1 nil t 5)
 756           (box-pack-start hbox (label-new "Books :") nil t 0)
 757           (box-pack-start hbox spin2 nil t 5)
 758           (box-pack-start hbox (label-new "Pages :") nil t 0)
 759           (box-pack-start hbox spin3 nil t 5)
 760
 761           (let ((button (button-new "Rebuild Tree")))
 762             (box-pack-start hbox button t t 0)
 763             (signal-connect
 764              button 'clicked
 765              #'(lambda ()
 766                  (let ((depth (spin-button-value-as-int spin1))
 767                        (books (spin-button-value-as-int spin2))
 768                        (pages (spin-button-value-as-int spin3)))
 769                    (rebuild-tree ctree depth books pages))))))
 770
 771         (let ((button (button-new "Close")))
 772           (box-pack-end hbox button t t 0)
 773           (signal-connect button 'clicked #'widget-destroy :object window)))
 774
 775       (let ((scrolled-window (scrolled-window-new)))
 776         (setf (container-border-width scrolled-window) 5)
 777         (setf (scrolled-window-hscrollbar-policy scrolled-window) :automatic)
 778         (setf (scrolled-window-vscrollbar-policy scrolled-window) :always)
 779         (box-pack-start vbox scrolled-window t t 0)
 780
 781         (container-add scrolled-window ctree)
 782         (setf (clist-column-auto-resize-p ctree 0) t)
 783         (setf (clist-column-width ctree 1) 200)
 784         (setf (clist-selection-mode ctree) :extended)
 785         (setf (ctree-line-style ctree) :dotted))
 786
 787       (signal-connect
 788        ctree 'click-column
 789        #'(lambda (column)
 790            (cond
 791             ((/= column (clist-sort-column ctree))
 792              (setf (clist-sort-column ctree) column))
 793             ((eq (clist-sort-type ctree) :ascending)
 794              (setf (clist-sort-type ctree) :descending))
 795             (t (setf (clist-sort-type ctree) :ascending)))
 796            (ctree-sort-recursive ctree)))
 797
 798       (signal-connect
 799        ctree 'button-press-event #'after-press :object t :after t)
 800       (signal-connect
 801        ctree 'button-release-event #'after-press :object t :after t)
 802       (signal-connect
 803        ctree 'tree-move #'after-press :object t :after t)
 804       (signal-connect
 805        ctree 'end-selection #'after-press :object t :after t)
 806       (signal-connect
 807        ctree 'toggle-focus-row #'after-press :object t :after t)
 808       (signal-connect
 809        ctree 'select-all #'after-press :object t :after t)
 810       (signal-connect
 811        ctree 'unselect-all #'after-press :object t :after t)
 812       (signal-connect
 813        ctree 'scroll-vertical #'after-press :object t :after t)
 814
 815       (let ((bbox (hbox-new nil 5)))
 816         (setf (container-border-width bbox) 5)
 817         (box-pack-start vbox bbox nil t 0)
 818
 819         (let ((mbox (vbox-new t 5)))
 820           (box-pack bbox mbox :expand nil)
 821           (box-pack mbox (label-new "Row Height :") :expand nil :fill nil)
 822           (box-pack mbox (label-new "Indent :") :expand nil :fill nil)
 823           (box-pack mbox (label-new "Spacing :") :expand nil :fill nil))
 824
 825         (let ((mbox (vbox-new t 5)))
 826           (box-pack bbox mbox :expand nil)
 827
 828           (let* ((adjustment (adjustment-new 20 12 100 1 10 0))
 829                  (spinner (spin-button-new adjustment 0 0)))
 830             (box-pack mbox spinner :expand nil :fill nil :padding 5)
 831             (flet ((set-row-height ()
 832                      (setf
 833                       (clist-row-height ctree)
 834                       (spin-button-value-as-int spinner))))
 835               (signal-connect adjustment 'value-changed #'set-row-height)
 836               (set-row-height)))
 837
 838           (let* ((adjustment (adjustment-new 20 0 60 1 10 0))
 839                  (spinner (spin-button-new adjustment 0 0)))
 840             (box-pack mbox spinner :expand nil :fill nil :padding 5)
 841             (flet ((set-indent ()
 842                      (setf
 843                       (ctree-indent ctree)
 844                       (spin-button-value-as-int spinner))))
 845               (signal-connect adjustment 'value-changed #'set-indent)
 846               (set-indent)))
 847
 848           (let* ((adjustment (adjustment-new 5 0 60 1 10 0))
 849                  (spinner (spin-button-new adjustment 0 0)))
 850             (box-pack mbox spinner :expand nil :fill nil :padding 5)
 851             (flet ((set-spacing ()
 852                      (setf
 853                       (ctree-spacing ctree)
 854                       (spin-button-value-as-int spinner))))
 855               (signal-connect adjustment 'value-changed #'set-spacing)
 856               (set-spacing))))
 857
 858
 859         (let ((mbox (vbox-new t 5)))
 860           (box-pack bbox mbox :expand nil)
 861
 862           (let ((hbox (hbox-new nil 5)))
 863             (box-pack mbox hbox :expand nil :fill nil)
 864
 865             (let ((button (button-new "Expand All")))
 866               (box-pack hbox button)
 867               (signal-connect
 868                button 'clicked
 869                #'(lambda ()
 870                    (ctree-expand-recursive ctree nil)
 871                    (after-press ctree))))
 872
 873             (let ((button (button-new "Collapse All")))
 874               (box-pack hbox button)
 875               (signal-connect
 876                button 'clicked
 877                #'(lambda ()
 878                    (ctree-collapse-recursive ctree nil)
 879                    (after-press ctree))))
 880
 881             (let ((button (button-new "Change Style")))
 882               (box-pack hbox button)
 883               (signal-connect
 884                button 'clicked
 885                #'(lambda ()
 886                    (let ((node (ctree-nth-node
 887                                 ctree (or (clist-focus-row ctree) 0))))
 888                      (when node
 889                        (unless style1
 890                          (let ((color1 '#(0 56000 0))
 891                                (color2 '#(32000 0 56000)))
 892                            (setq style1 (style-new))
 893                            (setf (style-base style1 :normal) color1)
 894                            (setf (style-fg style1 :selected) color2)
 895
 896                            (setq style2 (style-new))
 897                            (setf (style-base style2 :selected) color2)
 898                            (setf (style-base style2 :normal) color2)
 899                            (setf (style-fg style2 :normal) color1)
 900                            (setf
 901                             (style-font style2)
 902                             "-*-courier-medium-*-*-*-*-300-*-*-*-*-*-*")))
 903                        (setf (ctree-cell-style ctree node 1) style1)
 904                        (setf (ctree-cell-style ctree node 0) style2)
 905
 906                        (when (ctree-node-child node)
 907                          (setf
 908                           (ctree-row-style ctree (ctree-node-child node))
 909                           style2)))))))
 910
 911             (let ((button (button-new "Export Tree")))
 912               (box-pack hbox button)
 913               (signal-connect button 'clicked #'export-tree :object ctree)))
 914
 915           (let ((hbox (hbox-new nil 5)))
 916             (box-pack mbox hbox :expand nil :fill nil)
 917
 918             (let ((button (button-new "Select All")))
 919               (box-pack hbox button)
 920               (signal-connect
 921                button 'clicked
 922                #'(lambda ()
 923                    (ctree-select-recursive ctree nil)
 924                    (after-press ctree))))
 925
 926             (let ((button (button-new "Unselect All")))
 927               (box-pack hbox button)
 928               (signal-connect
 929                button 'clicked
 930                #'(lambda ()
 931                    (ctree-unselect-recursive ctree nil)
 932                    (after-press ctree))))
 933
 934             (let ((button (button-new "Remove Selection")))
 935               (box-pack hbox button)
 936               (signal-connect
 937                button 'clicked
 938                #'(lambda ()
 939                    (clist-freeze ctree)
 940                    (let ((selection-mode (clist-selection-mode ctree)))
 941                      (labels
 942                          ((remove-selection ()
 943                             (let ((node (first (ctree-selection ctree))))
 944                               (when node
 945
 946                                 (ctree-apply-post-recursive
 947                                  ctree node
 948                                  #'(lambda (node)
 949                                      (if (ctree-node-leaf-p node)
 950                                          (decf total-pages)
 951                                        (decf total-books))))
 952
 953                                 (ctree-remove-node ctree node)
 954                                 (unless (eq selection-mode :browse)
 955                                   (remove-selection))))))
 956                        (remove-selection))
 957
 958                      (when (and
 959                             (eq selection-mode :extended)
 960                             (not (clist-selection ctree))
 961                             (clist-focus-row ctree))
 962                        (ctree-select
 963                         ctree
 964                         (ctree-nth-node ctree (clist-focus-row ctree)))))
 965                    (clist-thaw ctree)
 966                    (after-press ctree))))
 967
 968             (let ((button (check-button-new "Reorderable")))
 969               (box-pack hbox button :expand nil)
 970               (signal-connect
 971                button 'clicked
 972                #'(lambda ()
 973                    (setf
 974                     (clist-reorderable-p ctree)
 975                     (toggle-button-active-p button))))
 976               (setf (toggle-button-active-p button) t)))
 977
 978           (let ((hbox (hbox-new nil 5)))
 979             (box-pack mbox hbox :expand nil :fill nil)
 980
 981             (flet
 982                 ((set-line-style (line-style)
 983                    (let ((current-line-style (ctree-line-style ctree)))
 984                      (when (or
 985                             (and
 986                              (eq current-line-style :tabbed)
 987                              (not (eq line-style :tabbed)))
 988                             (and
 989                              (not (eq current-line-style :tabbed))
 990                              (eq line-style :tabbed)))
 991                        (ctree-apply-pre-recursive
 992                         ctree nil
 993                         #'(lambda (node)
 994                             (let
 995                                 ((style
 996                                   (cond
 997                                    ((eq (ctree-line-style ctree) :tabbed) nil)
 998                                    ((not (ctree-node-leaf-p node))
 999                                     (ctree-node-data ctree node))
1000                                    ((ctree-node-parent node)
1001                                     (ctree-node-data
1002                                      ctree (ctree-node-parent node))))))
1003                               (setf (ctree-row-style ctree node) style))))
1004                        (setf (ctree-line-style ctree) line-style)))))
1005
1006               (let ((option-menu
1007                      (build-option-menu
1008                       `(("No lines" ,#'(lambda () (set-line-style :none)))
1009                         ("Solid" ,#'(lambda () (set-line-style :solid)))
1010                         ("Dotted" ,#'(lambda () (set-line-style :dotted)))
1011                         ("Tabbed" ,#'(lambda () (set-line-style :tabbed))))
1012                       2)))
1013                 (box-pack hbox option-menu :expand nil)))
1014
1015             (let ((option-menu
1016                    (build-option-menu
1017                     `(("None"
1018                        ,#'(lambda ()
1019                             (setf (ctree-expander-style ctree) :none)))
1020                       ("Square"
1021                        ,#'(lambda ()
1022                             (setf (ctree-expander-style ctree) :square)))
1023                       ("Triangle"
1024                        ,#'(lambda ()
1025                             (setf (ctree-expander-style ctree) :triangle)))
1026                       ("Circular"
1027                        ,#'(lambda ()
1028                             (setf (ctree-expander-style ctree) :circular))))
1029                     1)))
1030               (box-pack hbox option-menu :expand nil))
1031
1032             (let ((option-menu
1033                    (build-option-menu
1034                     `(("Left"
1035                        ,#'(lambda ()
1036                             (setf
1037                              (clist-column-justification ctree 0) :left)))
1038                       ("Right"
1039                        ,#'(lambda ()
1040                             (setf
1041                              (clist-column-justification ctree 0) :right))))
1042                     0)))
1043               (box-pack hbox option-menu :expand nil))
1044
1045             (flet ((set-sel-mode (mode)
1046                      (setf (clist-selection-mode ctree) mode)
1047                      (after-press ctree)))
1048               (let ((option-menu
1049                      (build-option-menu
1050                       `(("Single" ,#'(lambda () (set-sel-mode :single)))
1051                         ("Browse" ,#'(lambda () (set-sel-mode :browse)))
1052                         ("Multiple" ,#'(lambda () (set-sel-mode :multiple)))
1053                         ("Extended" ,#'(lambda () (set-sel-mode :extended))))
1054                       3)))
1055                 (box-pack hbox option-menu :expand nil))))))
1056
1057       (let ((frame (frame-new)))
1058         (setf (container-border-width frame) 0)
1059         (setf (frame-shadow-type frame) :out)
1060         (box-pack vbox frame :expand nil)
1061
1062         (let ((hbox (hbox-new t 2)))
1063           (setf (container-border-width hbox) 2)
1064           (container-add frame hbox)
1065
1066           (setq
1067            status-labels
1068            (map 'vector
1069             #'(lambda (text)
1070                 (let ((frame (frame-new))
1071                       (hbox2 (hbox-new nil 0)))
1072                   (setf (frame-shadow-type frame) :in)
1073                   (box-pack hbox frame :expand nil)
1074                   (setf (container-border-width hbox2) 2)
1075                   (container-add frame hbox2)
1076                   (box-pack hbox2 (label-new text) :expand nil)
1077                   (let ((label (label-new "")))
1078                     (box-pack-end hbox2 label nil t 5)
1079                     label)))
1080             '("Books :" "Pages :" "Selected :" "Visible :")))))
1081
1082       (widget-realize window)
1083       (let ((gdk:window (widget-window window)))
1084         (setq pixmap1 (multiple-value-list
1085                        (gdk:pixmap-create book-closed-xpm :window gdk:window)))
1086         (setq pixmap2 (multiple-value-list
1087                        (gdk:pixmap-create book-open-xpm :window gdk:window)))
1088         (setq pixmap3 (multiple-value-list
1089                        (gdk:pixmap-create mini-page-xpm :window gdk:window))))
1090       (setf (widget-height ctree) 300)
1091
1092       (rebuild-tree ctree 4 3 5))))
1093
1094
1095
1096 ;;; Cursors
1097
1098 (defun clamp (n min-val max-val)
1099   (declare (number n min-val max-val))
1100   (max (min n max-val) min-val))
1101
1102 (defun set-cursor (spinner drawing-area label)
1103   (let ((cursor
1104          (gforeign:int-enum
1105           (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
1106           'gdk:cursor-type)))
1107     (setf (label-text label) (string-downcase (symbol-name cursor)))
1108     (setf (widget-cursor drawing-area) cursor)))
1109
1110
1111 (define-standard-dialog create-cursors "Cursors"
1112   (setf (container-border-width main-box) 10)
1113   (setf (box-spacing main-box) 5)
1114   (let* ((hbox (hbox-new nil 0))
1115          (label (label-new "Cursor Value : "))
1116          (adj (adjustment-new 0 0 152 2 10 0))
1117          (spinner (spin-button-new adj 0 0)))
1118     (setf (container-border-width hbox) 5)
1119     (box-pack-start main-box hbox nil t 0)
1120     (setf (misc-xalign label) 0)
1121     (setf (misc-yalign label) 0.5)
1122     (box-pack-start hbox label nil t 0)
1123     (box-pack-start hbox spinner t t 0)
1124
1125     (let ((frame (make-frame
1126                   :shadow-type :etched-in
1127                   :label-xalign 0.5
1128                   :label "Cursor Area"
1129                   :border-width 10
1130                   :parent main-box
1131                   :visible t))
1132           (drawing-area (drawing-area-new)))
1133       (setf (widget-width drawing-area) 80)
1134       (setf (widget-height drawing-area) 80)
1135       (container-add frame drawing-area)
1136       (signal-connect
1137        drawing-area 'expose-event
1138        #'(lambda (event)
1139            (declare (ignore event))
1140            (multiple-value-bind (width height)
1141                (drawing-area-size drawing-area)
1142              (let* ((drawable (widget-window drawing-area))
1143                     (style (widget-style drawing-area))
1144                     (white-gc (style-get-gc style :white))
1145                     (gray-gc (style-get-gc style :background :normal))
1146                     (black-gc (style-get-gc style :black)))
1147                (gdk:draw-rectangle
1148                 drawable white-gc t 0 0 width (floor height 2))
1149                (gdk:draw-rectangle
1150                 drawable black-gc t 0 (floor height 2) width (floor height 2))
1151                (gdk:draw-rectangle
1152                 drawable gray-gc t (floor width 3) (floor height 3)
1153                 (floor width 3) (floor height 3))))
1154              t))
1155       (setf (widget-events drawing-area) '(:exposure :button-press))
1156       (signal-connect
1157        drawing-area 'button-press-event
1158        #'(lambda (event)
1159            (when (and
1160                   (eq (gdk:event-type event) :button-press)
1161                   (or
1162                    (= (gdk:event-button event) 1)
1163                    (= (gdk:event-button event) 3)))
1164              (spin-button-spin
1165               spinner
1166               (if (= (gdk:event-button event) 1)
1167                   :step-forward
1168                 :step-backward)
1169               0)
1170              t)))
1171       (widget-show drawing-area)
1172
1173     (let ((label (make-label
1174                   :visible t
1175                   :label "XXX"
1176                   :parent main-box)))
1177       (setf (box-child-expand-p #|main-box|# label) nil)
1178       (signal-connect
1179        spinner 'changed
1180        #'(lambda ()
1181            (set-cursor spinner drawing-area label)))
1182
1183       (widget-realize drawing-area)
1184       (set-cursor spinner drawing-area label)))))
1185
1186
1187
1188 ;;; Dialog
1189
1190 (define-test-dialog create-dialog "Dialog"
1191   (setf (widget-width window) 200)
1192   (setf (widget-height window) 110)
1193
1194   (let ((button (button-new "OK")))
1195     (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
1196     (setf (widget-can-default-p button) t)
1197     (box-pack-start action-area button t t 0)
1198     (widget-grab-default button)
1199     (widget-show button))
1200
1201   (let ((button (button-new "Toggle"))
1202         (label nil))
1203     (signal-connect
1204      button 'clicked
1205      #'(lambda ()
1206          (if (not label)
1207              (progn
1208                (setq label (label-new "Dialog Test"))
1209                (signal-connect label 'destroy #'widget-destroy :object label)
1210                (setf (misc-xpad label) 10)
1211                (setf (misc-ypad label) 10)
1212                (box-pack-start main-box label t t 0)
1213                (widget-show label))
1214            (progn
1215              (widget-destroy label)
1216              (setq label nil)))))
1217     (setf (widget-can-default-p button) t)
1218     (box-pack-start action-area button t t 0)
1219     (widget-grab-default button)
1220     (widget-show button)))
1221
1222
1223
1224 ;; Entry
1225
1226 (define-standard-dialog create-entry "Entry"
1227   (setf (container-border-width main-box) 10)
1228   (setf (box-spacing main-box) 10)
1229   (let ((entry (make-instance 'entry
1230                 :test "hello world"
1231                 :visible t
1232                 :parent (list main-box :fill t :expand t))))
1233     (entry-select-region entry 0 5)
1234
1235     (let ((combo (make-instance 'combo
1236                   :visible t
1237                   :parent (list main-box :expand t :fill t))))
1238       (setf
1239        (combo-popdown-strings combo)
1240        '("item0"
1241          "item1 item1"
1242          "item2 item2 item2"
1243          "item3 item3 item3 item3"
1244          "item4 item4 item4 item4 item4"
1245          "item5 item5 item5 item5 item5 item5"
1246          "item6 item6 item6 item6 item6"
1247          "item7 item7 item7 item7"
1248          "item8 item8 item8"
1249          "item9 item9"))
1250       (editable-select-region entry 0 5))
1251
1252     (let ((check-button (check-button-new "Editable")))
1253       (box-pack-start main-box check-button nil t 0)
1254       (signal-connect
1255        check-button 'toggled
1256        #'(lambda ()
1257            (setf
1258             (editable-editable-p entry)
1259             (toggle-button-active-p check-button))))
1260       (setf (toggle-button-active-p check-button) t)
1261       (widget-show check-button))
1262
1263     (let ((check-button (check-button-new "Visible")))
1264       (box-pack-start main-box check-button nil t 0)
1265       (signal-connect
1266        check-button 'toggled
1267        #'(lambda ()
1268            (setf
1269             (entry-visible-p entry)
1270             (toggle-button-active-p check-button))))
1271       (setf (toggle-button-active-p check-button) t)
1272       (widget-show check-button))
1273
1274     (let ((check-button (check-button-new "Sensitive")))
1275       (box-pack-start main-box check-button nil t 0)
1276       (signal-connect
1277        check-button 'toggled
1278        #'(lambda ()
1279            (setf
1280             (widget-sensitive-p entry)
1281             (toggle-button-active-p check-button))))
1282       (setf (toggle-button-active-p check-button) t)
1283       (widget-show check-button))))
1284
1285
1286
1287 ;; File selecetion dialog
1288
1289 (let ((filesel nil))
1290   (defun create-file-selection ()
1291     (unless filesel
1292       (setq filesel (file-selection-new "file selection dialog"))
1293       (file-selection-hide-fileop-buttons filesel)
1294       (setf (window-position filesel) :mouse)
1295       (signal-connect
1296        filesel 'destroy #'(lambda () (widget-destroyed filesel)))
1297       (signal-connect
1298        (file-selection-ok-button filesel) 'clicked
1299        #'(lambda ()
1300            (format
1301             t "Selected file: ~A~%" (file-selection-filename filesel))
1302            (widget-destroy filesel)))
1303       (signal-connect
1304        (file-selection-cancel-button filesel) 'clicked
1305        #'widget-destroy :object filesel)
1306
1307       (let ((button (button-new "Hide Fileops")))
1308         (signal-connect
1309          button 'clicked
1310          #'file-selection-hide-fileop-buttons :object filesel)
1311         (box-pack-start (file-selection-action-area filesel) button nil nil 0)
1312         (widget-show button))
1313
1314       (let ((button (button-new "Show Fileops")))
1315         (signal-connect
1316          button 'clicked
1317          #'file-selection-show-fileop-buttons :object filesel)
1318         (box-pack-start (file-selection-action-area filesel) button nil nil 0)
1319         (widget-show button)))
1320
1321     (if (not (widget-visible-p filesel))
1322         (widget-show-all filesel)
1323       (widget-destroy filesel))))
1324
1325
1326
1327 ;;; Handle box
1328
1329 (defun create-handle-box-toolbar ()
1330   (let ((toolbar (toolbar-new :horizontal :both)))
1331     (toolbar-append-item
1332      toolbar "Horizontal" (pixmap-new "cl-gtk:src;test.xpm")
1333      :tooltip-text "Horizontal toolbar layout"
1334      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1335
1336     (toolbar-append-item
1337      toolbar "Vertical" (pixmap-new "cl-gtk:src;test.xpm")
1338      :tooltip-text "Vertical toolbar layout"
1339      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1340
1341     (toolbar-append-space toolbar)
1342
1343     (toolbar-append-item
1344      toolbar "Icons" (pixmap-new "cl-gtk:src;test.xpm")
1345      :tooltip-text "Only show toolbar icons"
1346      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1347
1348     (toolbar-append-item
1349      toolbar "Text" (pixmap-new "cl-gtk:src;test.xpm")
1350      :tooltip-text "Only show toolbar text"
1351      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1352
1353     (toolbar-append-item
1354      toolbar "Both" (pixmap-new "cl-gtk:src;test.xpm")
1355      :tooltip-text "Show toolbar icons and text"
1356      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1357
1358     (toolbar-append-space toolbar)
1359
1360     (toolbar-append-item
1361      toolbar "Small" (pixmap-new "cl-gtk:src;test.xpm")
1362      :tooltip-text "Use small spaces"
1363      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
1364
1365     (toolbar-append-item
1366      toolbar "Big" (pixmap-new "cl-gtk:src;test.xpm")
1367      :tooltip-text "Use big spaces"
1368      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
1369
1370     (toolbar-append-space toolbar)
1371
1372     (toolbar-append-item
1373      toolbar "Enable" (pixmap-new "cl-gtk:src;test.xpm")
1374      :tooltip-text "Enable tooltips"
1375      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1376
1377     (toolbar-append-item
1378      toolbar "Disable" (pixmap-new "cl-gtk:src;test.xpm")
1379      :tooltip-text "Disable tooltips"
1380      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1381
1382     (toolbar-append-space toolbar)
1383
1384     (toolbar-append-item
1385      toolbar "Borders" (pixmap-new "cl-gtk:src;test.xpm")
1386      :tooltip-text "Show borders"
1387      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
1388
1389     (toolbar-append-item
1390      toolbar "Borderless" (pixmap-new "cl-gtk:src;test.xpm")
1391      :tooltip-text "Hide borders"
1392      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1393
1394     toolbar))
1395
1396
1397 (defun handle-box-child-signal (handle-box child action)
1398   (format t "~S: child ~S ~A~%" handle-box child action))
1399
1400
1401 (define-test-window create-handle-box "Handle Box Test"
1402   (setf (window-allow-grow-p window) t)
1403   (setf (window-allow-shrink-p window) t)
1404   (setf (window-auto-shrink-p window) nil)
1405   (setf (container-border-width window) 20)
1406   (let ((vbox (vbox-new nil 0)))
1407     (container-add window vbox)
1408
1409     (container-add vbox (label-new "Above"))
1410     (container-add vbox (hseparator-new))
1411
1412     (let ((hbox (hbox-new nil 10)))
1413       (container-add vbox hbox)
1414
1415       (let ((handle-box (handle-box-new)))
1416         (box-pack-start hbox handle-box nil nil 0)
1417         (signal-connect
1418          handle-box 'child-attached
1419          #'(lambda (child)
1420              (handle-box-child-signal handle-box child "attached")))
1421         (signal-connect
1422          handle-box 'child-detached
1423          #'(lambda (child)
1424              (handle-box-child-signal handle-box child "detached")))
1425         (container-add handle-box (create-handle-box-toolbar)))
1426
1427       (let ((handle-box (handle-box-new)))
1428         (box-pack-start hbox handle-box nil nil 0)
1429         (signal-connect
1430          handle-box 'child-attached
1431          #'(lambda (child)
1432              (handle-box-child-signal handle-box child "attached")))
1433         (signal-connect
1434          handle-box 'child-detached
1435          #'(lambda (child)
1436              (handle-box-child-signal handle-box child "detached")))
1437
1438         (let ((handle-box2 (handle-box-new)))
1439           (container-add handle-box handle-box2)
1440           (signal-connect
1441            handle-box2 'child-attached
1442            #'(lambda (child)
1443                (handle-box-child-signal handle-box child "attached")))
1444           (signal-connect
1445            handle-box2 'child-detached
1446            #'(lambda (child)
1447                (handle-box-child-signal handle-box child "detached")))
1448           (container-add handle-box2 (label-new "Foo!")))))
1449
1450     (container-add vbox (hseparator-new))
1451     (container-add vbox (label-new "Below"))))
1452
1453
1454
1455 ;;; Labels
1456
1457 (define-test-window create-labels "Labels"
1458   (setf (container-border-width window) 5)
1459   (let ((hbox (hbox-new nil 5)))
1460     (container-add window hbox)
1461     (let ((vbox (vbox-new nil 5)))
1462       (box-pack-start hbox vbox nil nil 0)
1463
1464       (let ((frame (frame-new  "Normal Label")))
1465         (container-add frame (label-new "This is a Normal label"))
1466         (box-pack-start vbox frame nil nil 0))
1467
1468       (let ((frame (frame-new  "Multi-line Label")))
1469         (container-add frame (label-new
1470 "This is a Multi-line label.
1471 Second line
1472 Third line"))
1473         (box-pack-start vbox frame nil nil 0))
1474
1475       (let ((frame (frame-new  "Left Justified Label"))
1476             (label (label-new
1477 "This is a Left-Justified
1478 Multi-line.
1479 Third line")))
1480         (setf (label-justify label) :left)
1481         (container-add frame label)
1482         (box-pack-start vbox frame nil nil 0))
1483
1484       (let ((frame (frame-new  "Right Justified Label"))
1485             (label (label-new
1486 "This is a Right-Justified
1487 Multi-line.
1488 Third line")))
1489         (setf (label-justify label) :right)
1490         (container-add frame label)
1491         (box-pack-start vbox frame nil nil 0)))
1492
1493     (let ((vbox (vbox-new nil 5)))
1494       (box-pack-start hbox vbox nil nil 0)
1495
1496       (let ((frame (frame-new  "Line wrapped label"))
1497             (label (label-new
1498 "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.
1499      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. ")))
1500         (setf (label-wrap-p label) t)
1501         (container-add frame label)
1502         (box-pack-start vbox frame nil nil 0))
1503
1504       (let ((frame (frame-new  "Filled, wrapped label"))
1505             (label (label-new
1506 "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.
1507     This is a new paragraph.
1508     This is another newer, longer, better paragraph.  It is coming to an end, unfortunately.")))
1509         (setf (label-justify label) :fill)
1510         (setf (label-wrap-p label) t)
1511         (container-add frame label)
1512         (box-pack-start vbox frame nil nil 0))
1513
1514       (let ((frame (frame-new  "Underlined label"))
1515             (label (label-new
1516 "This label is underlined!
1517 This one is underlined in ÆüËÜ¸ì¤ÎÆþÍÑquite a funky fashion")))
1518         (setf (label-justify label) :left)
1519         (setf (label-pattern label) "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")
1520         (container-add frame label)
1521         (box-pack-start vbox frame nil nil 0)))))
1522
1523
1524
1525 ;;; Layout
1526
1527 (defun layout-expose-handler (layout event)
1528   (multiple-value-bind (x-offset y-offset)
1529       (layout-offset layout)
1530     (declare (fixnum x-offset y-offset))
1531     (multiple-value-bind (area-x area-y area-width area-height)
1532         (gdk:event-area event)
1533       (declare (fixnum area-x area-y area-width area-height))
1534       (let ((imin (truncate (+ x-offset area-x) 10))
1535             (imax (truncate (+ x-offset area-x area-width 9) 10))
1536             (jmin (truncate (+ y-offset area-y) 10))
1537             (jmax (truncate (+ y-offset area-y area-height 9) 10)))
1538         (declare (fixnum imin imax jmin jmax))
1539         (gdk:window-clear-area
1540          (widget-window layout) area-x area-y area-width area-height)
1541
1542         (let ((window (layout-bin-window layout))
1543               (gc (style-get-gc (widget-style layout) :black)))
1544           (do ((i imin (1+ i)))
1545               ((= i imax))
1546             (declare (fixnum i))
1547             (do ((j jmin (1+ j)))
1548                 ((= j jmax))
1549               (declare (fixnum j))
1550               (unless (zerop (mod (+ i j) 2))
1551                 (gdk:draw-rectangle
1552                  window gc t
1553                  (- (* 10 i) x-offset) (- (* 10 j) y-offset)
1554                  (1+ (mod i 10)) (1+ (mod j 10))))))))))
1555   t)
1556
1557
1558 (define-test-window create-layout "Layout"
1559   (setf (widget-width window) 200)
1560   (setf (widget-height window) 200)
1561   (let ((scrolled (scrolled-window-new))
1562         (layout (layout-new)))
1563     (container-add window scrolled)
1564     (container-add scrolled layout)
1565     (setf (adjustment-step-increment (layout-hadjustment layout)) 10.0)
1566     (setf (adjustment-step-increment (layout-vadjustment layout)) 10.0)
1567     (setf (widget-events layout) '(:exposure))
1568     (signal-connect layout 'expose-event #'layout-expose-handler :object t)
1569     (setf (layout-size layout) '#(1600 128000))
1570
1571     (dotimes (i 16)
1572       (dotimes (j 16)
1573         (let* ((text (format nil "Button ~D, ~D" i j))
1574                (button (if (not (zerop (mod (+ i j) 2)))
1575                            (button-new text)
1576                          (label-new text))))
1577           (layout-put layout button (* j 100) (* i 100)))))
1578
1579     (do ((i 16 (1+ i)))
1580         ((= i 1280))
1581       (declare (fixnum i))
1582       (let* ((text (format nil "Button ~D, ~D" i 0))
1583              (button (if (not (zerop (mod i 2)))
1584                          (button-new text)
1585                        (label-new text))))
1586         (layout-put layout button 0 (* i 100))))))
1587
1588
1589
1590 ;;; List
1591
1592 (define-standard-dialog create-list "List"
1593   (let ((scrolled-window (scrolled-window-new))
1594         (list (list-new)))
1595     (setf (container-border-width scrolled-window) 5)
1596     (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
1597     (box-pack-start main-box scrolled-window t t 0)
1598     (setf (widget-height scrolled-window) 300)
1599
1600     (setf (list-selection-mode list) :extended)
1601     (scrolled-window-add-with-viewport scrolled-window list)
1602     (setf
1603      (container-focus-vadjustment list)
1604      (scrolled-window-vadjustment scrolled-window))
1605     (setf
1606      (container-focus-hadjustment list)
1607      (scrolled-window-hadjustment scrolled-window))
1608
1609     (with-open-file (file "cl-gtk:src;gtktypes.lisp")
1610       (labels ((read-file ()
1611                  (let ((line (read-line file nil nil)))
1612                    (when line
1613                      (container-add list (list-item-new line))
1614                      (read-file)))))
1615         (read-file)))
1616
1617     (let ((hbox (hbox-new t 5)))
1618       (setf (container-border-width hbox) 5)
1619       (box-pack-start main-box hbox nil t 0)
1620
1621       (let ((button (button-new "Insert Row"))
1622             (i 0))
1623         (box-pack-start hbox button t t 0)
1624         (signal-connect
1625          button 'clicked
1626          #'(lambda ()
1627              (let ((item
1628                     (list-item-new (format nil "added item ~A" (incf i)))))
1629                (widget-show item)
1630                (container-add list item)))))
1631
1632       (let ((button (button-new "Clear List")))
1633         (box-pack-start hbox button t t 0)
1634         (signal-connect
1635          button 'clicked #'(lambda () (list-clear-items list 0 -1))))
1636
1637       (let ((button (button-new "Remove Selection")))
1638         (box-pack-start hbox button t t 0)
1639         (signal-connect
1640          button 'clicked
1641          #'(lambda ()
1642              (let ((selection (list-selection list)))
1643                (if (eq (list-selection-mode list) :extended)
1644                    (let ((item (or
1645                                 (container-focus-child list)
1646                                 (first selection))))
1647                      (when item
1648                        (let* ((children (container-children list))
1649                               (sel-row
1650                                (or
1651                                 (find-if
1652                                  #'(lambda (item)
1653                                      (eq (widget-state item) :selected))
1654                                  (member item children))
1655                                 (find-if
1656                                  #'(lambda (item)
1657                                      (eq (widget-state item) :selected))
1658                                  (member item (reverse children))))))
1659                          (list-remove-items list selection)
1660                          (when sel-row
1661                            (list-select-child list sel-row)))))
1662                  (list-remove-items list selection)))))
1663         (box-pack-start hbox button t t 0)))
1664
1665     (let ((cbox (hbox-new nil 0)))
1666       (box-pack-start main-box cbox nil t 0)
1667
1668       (let ((hbox (hbox-new nil 5))
1669             (option-menu
1670              (build-option-menu
1671               `(("Single"
1672                  ,#'(lambda () (setf (list-selection-mode list) :single)))
1673                 ("Browse"
1674                  ,#'(lambda () (setf (list-selection-mode list) :browse)))
1675                 ("Multiple"
1676                  ,#'(lambda () (setf (list-selection-mode list) :multiple)))
1677                 ("Extended"
1678                  ,#'(lambda () (setf (list-selection-mode list) :extended))))
1679               3)))
1680
1681         (setf (container-border-width hbox) 5)
1682         (box-pack-start cbox hbox t nil 0)
1683         (box-pack-start hbox (label-new "Selection Mode :") nil t 0)
1684         (box-pack-start hbox option-menu nil t 0)))))
1685
1686
1687
1688 ;; Menus
1689
1690 (defun create-menu (depth tearoff)
1691   (unless (zerop depth)
1692     (let ((menu (menu-new)))
1693       (when tearoff
1694         (let ((menuitem (tearoff-menu-item-new)))
1695           (menu-append menu menuitem)
1696           (widget-show menuitem)
1697           ))
1698       (let ((group nil))
1699         (dotimes (i 5)
1700           (let ((menuitem
1701                  (radio-menu-item-new
1702                   group (format nil "item ~2D - ~D" depth (1+ i)))))
1703             (setq group (radio-menu-item-group menuitem)) ; ough!
1704             (unless (zerop (mod depth 2))
1705             (setf (check-menu-item-toggle-indicator-p menuitem) t))
1706             (menu-append menu menuitem)
1707             (widget-show menuitem)
1708             (when (= i 3)
1709               (setf (widget-sensitive-p menuitem) nil))
1710             (setf (menu-item-submenu menuitem) (create-menu (1- depth) t)))))
1711       menu)))
1712
1713
1714 (define-standard-dialog create-menus "Menus"
1715   (setf (box-spacing main-box) 0)
1716   (setf (container-border-width main-box) 0)
1717   (widget-show main-box)
1718   (let ((accel-group (accel-group-new))
1719         (menubar (menu-bar-new)))
1720     (accel-group-attach accel-group window)
1721     (box-pack-start main-box menubar nil t 0)
1722     (widget-show menubar)
1723
1724     (let ((menuitem (menu-item-new (format nil "test~%line2"))))
1725       (setf (menu-item-submenu menuitem) (create-menu 2 t))
1726       (menu-bar-append menubar menuitem)
1727       (widget-show menuitem))
1728
1729     (let ((menuitem (menu-item-new "foo")))
1730       (setf (menu-item-submenu menuitem) (create-menu 3 t))
1731       (menu-bar-append menubar menuitem)
1732       (widget-show menuitem))
1733
1734     (let ((menuitem (menu-item-new "bar")))
1735       (setf (menu-item-submenu menuitem) (create-menu 4 t))
1736       (menu-item-right-justify menuitem)
1737       (menu-bar-append menubar menuitem)
1738       (widget-show menuitem))
1739
1740     (let ((box2 (vbox-new nil 10))
1741           (menu (create-menu 1 nil)))
1742       (setf (container-border-width box2) 10)
1743       (box-pack-start main-box box2 t t 0)
1744       (widget-show box2)
1745
1746       (setf (menu-accel-group menu) accel-group)
1747
1748       (let ((menuitem (check-menu-item-new "Accelerate Me")))
1749         (menu-append menu menuitem)
1750         (widget-show menuitem)
1751         (widget-add-accelerator
1752          menuitem 'activate accel-group "F1" 0 '(:visible :signal-visible)))
1753
1754       (let ((menuitem (check-menu-item-new "Accelerator Locked")))
1755         (menu-append menu menuitem)
1756         (widget-show menuitem)
1757         (widget-add-accelerator
1758          menuitem 'activate accel-group "F2" 0 '(:visible :locked)))
1759
1760       (let ((menuitem (check-menu-item-new "Accelerator Frozen")))
1761         (menu-append menu menuitem)
1762         (widget-show menuitem)
1763         (widget-add-accelerator
1764          menuitem 'activate accel-group "F2" 0 '(:visible))
1765         (widget-add-accelerator
1766          menuitem 'activate accel-group "F3" 0 '(:visible))
1767         (widget-lock-accelerators menuitem))
1768
1769       (let ((optionmenu (option-menu-new)))
1770         (setf (option-menu-menu optionmenu) menu)
1771         (setf (option-menu-history optionmenu) 3)
1772         (box-pack-start box2 optionmenu t t 0)
1773         (widget-show optionmenu)))))
1774
1775
1776 ;;; Notebook
1777
1778 (define-standard-dialog create-notebook "Notebook"
1779   (multiple-value-bind (book-open book-open-mask)
1780       (gdk:pixmap-create book-open-xpm)
1781     (multiple-value-bind (book-closed book-closed-mask)
1782         (gdk:pixmap-create book-closed-xpm)
1783
1784       (labels
1785           ((create-pages (notebook i end)
1786              (when (<= i end)
1787                (let* ((title (format nil "Page ~D" i))
1788                       (child (frame-new title))
1789                       (vbox (vbox-new t 0))
1790                       (hbox (hbox-new t 0)))
1791                  (setf (container-border-width child) 10)
1792                  (setf (container-border-width vbox) 10)
1793                  (container-add child vbox)
1794                  (box-pack-start vbox hbox nil t 5)
1795
1796                  (let ((button (check-button-new "Fill Tab")))
1797                    (box-pack-start hbox button t t 5)
1798                    (setf (toggle-button-active-p button) t)
1799                    (signal-connect
1800                     button 'toggled
1801                     #'(lambda ()
1802                         (multiple-value-bind (expand fill pack-type)
1803                             (notebook-query-tab-label-packing notebook child)
1804                           (declare (ignore fill))
1805                           (notebook-set-tab-label-packing
1806                            notebook child expand
1807                            (toggle-button-active-p button) pack-type)))))
1808
1809                  (let ((button (check-button-new "Expand Tab")))
1810                    (box-pack-start hbox button t t 5)
1811                    (signal-connect
1812                     button 'toggled
1813                     #'(lambda ()
1814                         (multiple-value-bind (expand fill pack-type)
1815                             (notebook-query-tab-label-packing notebook child)
1816                           (declare (ignore expand))
1817                           (notebook-set-tab-label-packing
1818                            notebook child (toggle-button-active-p button)
1819                            fill pack-type)))))
1820
1821                  (let ((button (check-button-new "Pack end")))
1822                    (box-pack-start hbox button t t 5)
1823                    (signal-connect
1824                     button 'toggled
1825                     #'(lambda ()
1826                         (multiple-value-bind (expand fill pack-type)
1827                             (notebook-query-tab-label-packing notebook child)
1828                           (declare (ignore pack-type))
1829                           (notebook-set-tab-label-packing
1830                            notebook child expand fill
1831                            (if (toggle-button-active-p button)
1832                                :end
1833                              :start))))))
1834
1835                  (let ((button (button-new "Hide Page")))
1836                    (box-pack-start vbox button nil nil 5)
1837                    (signal-connect
1838                     button 'clicked #'(lambda () (widget-hide child))))
1839
1840                  (widget-show-all child)
1841
1842                  (let ((label-box (hbox-new nil 0))
1843                        (menu-box (hbox-new nil 0)))
1844                    (box-pack-start
1845                     label-box (pixmap-new (list book-closed book-closed-mask))
1846                     nil t 0)
1847                    (box-pack-start label-box (label-new title) nil t 0)
1848                    (widget-show-all label-box)
1849                    (box-pack-start
1850                     menu-box (pixmap-new (list book-closed book-closed-mask))
1851                     nil t 0)
1852                    (box-pack-start menu-box (label-new title) nil t 0)
1853                    (widget-show-all menu-box)
1854                    (notebook-append-page notebook child label-box menu-box)))
1855
1856                (create-pages notebook (1+ i) end))))
1857
1858
1859         (setf (container-border-width main-box) 0)
1860         (setf (box-spacing main-box) 0)
1861
1862         (let ((notebook (notebook-new)))
1863           (signal-connect
1864            notebook 'switch-page
1865            #'(lambda (pointer page)
1866                (declare (ignore pointer))
1867                (let ((old-page (notebook-current-page-num notebook)))
1868                  (unless (eq page old-page)
1869                    (setf
1870                     (pixmap-pixmap
1871                      (first
1872                       (container-children
1873                        (notebook-tab-label notebook page))))
1874                     (list book-open book-open-mask))
1875                    (setf
1876                     (pixmap-pixmap
1877                      (first
1878                       (container-children
1879                        (notebook-menu-label notebook page))))
1880                     (list book-open book-open-mask))
1881
1882                    (when old-page
1883                      (setf
1884                       (pixmap-pixmap
1885                        (first
1886                         (container-children
1887                          (notebook-tab-label notebook old-page))))
1888                       (list book-closed book-closed-mask))
1889                      (setf
1890                       (pixmap-pixmap
1891                        (first
1892                         (container-children
1893                          (notebook-menu-label notebook old-page))))
1894                       (list book-closed book-closed-mask)))))))
1895
1896           (setf (notebook-tab-pos notebook) :top)
1897           (box-pack-start main-box notebook t t 0)
1898           (setf (container-border-width notebook) 10)
1899
1900           (widget-realize notebook)
1901           (create-pages notebook 1 5)
1902
1903           (box-pack-start main-box (hseparator-new) nil t 10)
1904
1905           (let ((box2 (hbox-new nil 5)))
1906             (setf (container-border-width box2) 10)
1907             (box-pack-start main-box box2 nil t 0)
1908
1909             (let ((button (check-button-new "popup menu")))
1910               (box-pack-start box2 button t nil 0)
1911               (signal-connect
1912                button 'clicked
1913                #'(lambda ()
1914                    (if (toggle-button-active-p button)
1915                        (notebook-popup-enable notebook)
1916                      (notebook-popup-disable notebook)))))
1917
1918             (let ((button (check-button-new "homogeneous tabs")))
1919               (box-pack-start box2 button t nil 0)
1920               (signal-connect
1921                button 'clicked
1922                #'(lambda ()
1923                    (setf
1924                     (notebook-homogeneous-p notebook)
1925                     (toggle-button-active-p button))))))
1926
1927           (let ((box2 (hbox-new nil 5)))
1928             (setf (container-border-width box2) 10)
1929             (box-pack-start main-box box2 nil t 0)
1930
1931             (box-pack-start box2 (label-new "Notebook Style : ") nil t 0)
1932
1933             (let* ((scrollable-p nil)
1934                    (option-menu
1935                     (build-option-menu
1936                      `(("Standard"
1937                         ,#'(lambda ()
1938                              (setf (notebook-show-tabs-p notebook) t)
1939                              (when scrollable-p
1940                                (setq scrollable-p nil)
1941                                (setf (notebook-scrollable-p notebook) nil)
1942                                (dotimes (n 10)
1943                                  (notebook-remove-page notebook 5)))))
1944                        ("No tabs"
1945                        ,#'(lambda ()
1946                             (setf (notebook-show-tabs-p notebook) nil)
1947                             (when scrollable-p
1948                               (setq scrollable-p nil)
1949                               (setf (notebook-scrollable-p notebook) nil)
1950                               (dotimes (n 10)
1951                                 (notebook-remove-page notebook 5)))))
1952                        ("Scrollable"
1953                        ,#'(lambda ()
1954                             (unless scrollable-p
1955                               (setq scrollable-p t)
1956                               (setf (notebook-show-tabs-p notebook) t)
1957                               (setf (notebook-scrollable-p notebook) t)
1958                               (create-pages notebook 6 15)))))
1959                      0)))
1960               (box-pack-start box2 option-menu nil t 0))
1961
1962             (let ((button (button-new "Show all Pages")))
1963               (box-pack-start box2 button nil t 0)
1964               (signal-connect
1965                button 'clicked
1966                #'(lambda ()
1967                    (container-foreach notebook #'widget-show)))))
1968
1969           (let ((box2 (hbox-new nil 5)))
1970             (setf (container-border-width box2) 10)
1971             (box-pack-start main-box box2 nil t 0)
1972
1973             (let ((button (button-new "prev")))
1974               (box-pack-start box2 button t t 0)
1975               (signal-connect
1976                button 'clicked
1977                #'(lambda ()
1978                    (notebook-prev-page notebook))))
1979
1980             (let ((button (button-new "next")))
1981               (box-pack-start box2 button t t 0)
1982               (signal-connect
1983                button 'clicked
1984                #'(lambda ()
1985                    (notebook-next-page notebook))))
1986
1987             (let ((button (button-new "rotate"))
1988                   (tab-pos 2))
1989               (box-pack-start box2 button t t 0)
1990               (signal-connect
1991                button 'clicked
1992                #'(lambda ()
1993                    (setq tab-pos (mod (1+ tab-pos) 4))
1994                    (setf (notebook-tab-pos notebook) tab-pos))))))))))
1995
1996
1997
1998 ;;; Panes
1999
2000 (defun toggle-resize (child)
2001   (let* ((paned (widget-parent child))
2002          (is-child1-p (eq child (paned-child1 paned))))
2003     (multiple-value-bind (child resize shrink)
2004         (if is-child1-p
2005             (paned-child1 paned)
2006           (paned-child2 paned))
2007       (widget-ref child)
2008       (container-remove paned child)
2009       (if is-child1-p
2010           (paned-pack1 paned child (not resize) shrink)
2011         (paned-pack2 paned child (not resize) shrink))
2012       (widget-unref child))))
2013
2014 (defun toggle-shrink (child)
2015   (let* ((paned (widget-parent child))
2016          (is-child1-p (eq child (paned-child1 paned))))
2017     (multiple-value-bind (child resize shrink)
2018         (if is-child1-p
2019             (paned-child1 paned)
2020           (paned-child2 paned))
2021       (widget-ref child)
2022       (container-remove paned child)
2023       (if is-child1-p
2024           (paned-pack1 paned child resize (not shrink))
2025         (paned-pack2 paned child resize (not shrink)))
2026       (widget-unref child))))
2027
2028 (defun create-pane-options (paned frame-label label1 label2)
2029   (let ((frame (frame-new frame-label))
2030         (table (table-new 3 2 t)))
2031     (setf (container-border-width frame) 4)
2032     (container-add frame table)
2033
2034     (table-attach table (label-new label1) 0 1 0 1)
2035
2036     (let ((check-button (check-button-new "Resize")))
2037       (table-attach table check-button 0 1 1 2)
2038       (signal-connect
2039        check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
2040
2041     (let ((check-button (check-button-new "Shrink")))
2042       (table-attach table check-button 0 1 2 3)
2043       (setf (toggle-button-active-p check-button) t)
2044       (signal-connect
2045        check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
2046
2047     (table-attach table (label-new label2) 1 2 0 1)
2048
2049     (let ((check-button (check-button-new "Resize")))
2050       (table-attach table check-button 1 2 1 2)
2051       (setf (toggle-button-active-p check-button) t)
2052       (signal-connect
2053        check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
2054
2055     (let ((check-button (check-button-new "Shrink")))
2056       (table-attach table check-button 1 2 2 3)
2057       (setf (toggle-button-active-p check-button) t)
2058       (signal-connect
2059        check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
2060
2061     frame))
2062
2063 (define-test-window create-panes "Panes"
2064   (let ((vbox (vbox-new nil 0))
2065         (vpaned (vpaned-new))
2066         (hpaned (hpaned-new)))
2067     (container-add window vbox)
2068     (box-pack-start vbox vpaned t t 0)
2069     (setf (container-border-width vpaned) 5)
2070
2071     (paned-add1 vpaned hpaned)
2072
2073     (let ((frame (frame-new nil)))
2074       (setf (frame-shadow-type frame) :in)
2075       (setf (widget-width frame) 60)
2076       (setf (widget-height frame) 60)
2077       (paned-add1 hpaned frame)
2078       (container-add frame (button-new "Hi there")))
2079
2080     (let ((frame (frame-new nil)))
2081       (setf (frame-shadow-type frame) :in)
2082       (setf (widget-width frame) 80)
2083       (setf (widget-height frame) 60)
2084       (paned-add2 hpaned frame))
2085
2086     (let ((frame (frame-new nil)))
2087       (setf (frame-shadow-type frame) :in)
2088       (setf (widget-width frame) 80)
2089       (setf (widget-height frame) 60)
2090       (paned-add2 vpaned frame))
2091
2092     ;; Now create toggle buttons to control sizing
2093
2094     (box-pack-start
2095      vbox (create-pane-options hpaned "Horizontal" "Left" "Right") nil nil 0)
2096
2097     (box-pack-start
2098      vbox (create-pane-options vpaned "Vertical" "Top" "Bottom") nil nil 0)))
2099
2100
2101
2102 ;;; Pixmap
2103
2104 (define-standard-dialog create-pixmap "Pixmap"
2105   (setf (container-border-width main-box) 10)
2106   (let* ((button (button-new))
2107          (hbox (hbox-new nil 0)))
2108     (box-pack-start main-box button nil nil 0)
2109     (container-add button hbox)
2110     (setf (container-border-width hbox) 2)
2111     (container-add hbox (pixmap-new "cl-gtk:src;test.xpm"))
2112     (container-add hbox (label-new "Pixmap test"))))
2113
2114
2115
2116 ;;; Progress bar
2117
2118 (define-standard-dialog create-progress-bar "Progress bar"
2119   (setf (window-allow-grow-p window) nil)
2120   (setf (window-allow-shrink-p window) nil)
2121   (setf (window-auto-shrink-p window) t)
2122
2123   (setf (container-border-width main-box) 10)
2124
2125   (let* ((pbar-adj (adjustment-new 0 1 300 0 0 0))
2126          (pbar (progress-bar-new pbar-adj))
2127          (user-label (label-new "")))
2128
2129     (let ((frame (frame-new "Progress"))
2130           (vbox (vbox-new nil 5)))
2131       (box-pack-start main-box frame nil t 0)
2132       (container-add frame vbox)
2133
2134       (let ((timer (timeout-add
2135                     100
2136                     #'(lambda ()
2137                         (let* ((value (adjustment-value pbar-adj))
2138                                (new-value
2139                                 (if (= value (adjustment-upper pbar-adj))
2140                                     (adjustment-lower pbar-adj)
2141                                   (1+ value))))
2142                           (setf (progress-value pbar) new-value))
2143                         t))))
2144         (signal-connect window 'destroy #'(lambda () (timeout-remove timer))))
2145
2146       (signal-connect
2147        pbar-adj 'value-changed
2148        #'(lambda ()
2149            (setf
2150             (label-text user-label)
2151             (if (progress-activity-mode-p pbar)
2152                 "???"
2153               (format nil "~D" (round (* 100 (progress-percentage pbar))))))))
2154
2155       (setf (progress-format-string pbar) "%v from [%l,%u] (=%p%%)")
2156
2157       (let ((align (alignment-new 0.5 0.5 0.0 0.0)))
2158         (box-pack-start vbox align nil nil 0)
2159         (container-add align pbar))
2160
2161       (let ((hbox (hbox-new nil 5)))
2162         (box-pack-start hbox (label-new "Label updated by user :") nil t 0)
2163         (box-pack-start hbox user-label nil t 0)
2164
2165         (let ((align (alignment-new 0.5 0.5 0.0 0.0)))
2166           (box-pack-start vbox align nil nil 5)
2167           (container-add align hbox))))
2168
2169     (let ((frame (frame-new "Options"))
2170           (vbox (vbox-new nil 5)))
2171       (box-pack-start main-box frame nil t 0)
2172       (container-add frame vbox)
2173
2174       (let ((table (table-new 7 2 nil)))
2175         (box-pack-start vbox table nil t 0)
2176
2177         (let ((label (label-new "Orientation :")))
2178           (setf (misc-xalign label) 0.0)
2179           (setf (misc-yalign label) 0.5)
2180           (table-attach table label 0 1 0 1 :x-padding 5 :y-padding 5))
2181
2182         (let ((hbox (hbox-new nil 0)))
2183           (box-pack-start
2184            hbox
2185            (build-option-menu
2186             `(("Left-Right"
2187                ,#'(lambda ()
2188                     (setf (progress-bar-orientation pbar) :left-to-right)))
2189               ("Right-Left"
2190                ,#'(lambda ()
2191                     (setf (progress-bar-orientation pbar) :right-to-left)))
2192               ("Bottom-Top"
2193                ,#'(lambda ()
2194                     (setf (progress-bar-orientation pbar) :bottom-to-top)))
2195               ("Top-Bottom"
2196                ,#'(lambda ()
2197                     (setf (progress-bar-orientation pbar) :top-to-bottom))))
2198             0)
2199            t t 0)
2200           (table-attach table hbox 1 2 0 1 :x-padding 5 :y-padding 5))
2201
2202         (let* ((button (check-button-new "Show text"))
2203                (entry (entry-new))
2204                (x-align-adj (adjustment-new 0.5 0.0 1.0 0.1 0.1 0.0))
2205                (x-align-spin (spin-button-new x-align-adj 0 1))
2206                (y-align-adj (adjustment-new 0.5 0.0 1.0 0.1 0.1 0.0))
2207                (y-align-spin (spin-button-new y-align-adj 0 1)))
2208
2209           (signal-connect
2210            button 'clicked
2211            #'(lambda ()
2212                (let ((state (toggle-button-active-p button)))
2213                  (setf (progress-show-text-p pbar) state)
2214                  (setf (widget-sensitive-p entry) state)
2215                  (setf (widget-sensitive-p x-align-spin) state)
2216                  (setf (widget-sensitive-p y-align-spin) state))))
2217           (table-attach table button 0 1 1 2 :x-padding 5 :y-padding 5)
2218
2219           (signal-connect
2220            entry 'changed
2221            #'(lambda ()
2222                (setf
2223                 (progress-format-string pbar)
2224                 (entry-text entry))))
2225           (setf (entry-text entry) "%v from [%l,%u] (=%p%%)")
2226           (setf (widget-width entry) 100)
2227           (setf (widget-sensitive-p entry) nil)
2228
2229           (let ((hbox (hbox-new nil 0)))
2230             (box-pack-start hbox (label-new "Format : ") nil t 0)
2231             (box-pack-start hbox entry t t 0)
2232             (table-attach table hbox 1 2 1 2 :x-padding 5 :y-padding 5))
2233
2234           (let ((label (label-new "Text align :")))
2235             (setf (misc-xalign label) 0.0)
2236             (setf (misc-yalign label) 0.5)
2237             (table-attach table label 0 1 2 3 :x-padding 5 :y-padding 5))
2238
2239           (flet ((adjust-align ()
2240                    (setf
2241                     (progress-text-xalign pbar)
2242                     (spin-button-value x-align-spin))
2243                    (setf
2244                     (progress-text-yalign pbar)
2245                     (spin-button-value y-align-spin))))
2246             (signal-connect x-align-adj 'value-changed #'adjust-align)
2247             (signal-connect y-align-adj 'value-changed #'adjust-align))
2248           (setf (widget-sensitive-p x-align-spin) nil)
2249           (setf (widget-sensitive-p y-align-spin) nil)
2250
2251           (let ((hbox (hbox-new nil 0)))
2252             (box-pack-start hbox (label-new "x :") nil t 5)
2253             (box-pack-start hbox x-align-spin nil t 0)
2254             (box-pack-start hbox (label-new "y :") nil t 5)
2255             (box-pack-start hbox y-align-spin nil t 0)
2256             (table-attach table hbox 1 2 2 3 :x-padding 5 :y-padding 5)))
2257
2258         (let ((label (label-new "Bar Style :")))
2259           (setf (misc-xalign label) 0.0)
2260           (setf (misc-yalign label) 0.5)
2261           (table-attach table label 0 1 3 4 :x-padding 5 :y-padding 5))
2262
2263         (let* ((block-adj (adjustment-new 10 2 20 1 5 0))
2264                (block-spin (spin-button-new block-adj 0 0)))
2265           (let ((hbox (hbox-new nil 0)))
2266             (box-pack-start
2267              hbox
2268              (build-option-menu
2269               `(("Continuous"
2270                  ,#'(lambda ()
2271                       (setf (progress-bar-style pbar) :continuous)
2272                       (setf (widget-sensitive-p block-spin) nil)))
2273                 ("Discrete"
2274                  ,#'(lambda ()
2275                       (setf (progress-bar-style pbar) :discrete)
2276                       (setf (widget-sensitive-p block-spin) t))))
2277               0)
2278              t t 0)
2279             (table-attach table hbox 1 2 3 4 :x-padding 5 :y-padding 5))
2280
2281           (let ((label (label-new "Block count :")))
2282             (setf (misc-xalign label) 0.0)
2283             (setf (misc-yalign label) 0.5)
2284             (table-attach table label 0 1 4 5 :x-padding 5 :y-padding 5))
2285
2286           (signal-connect
2287            block-adj 'value-changed
2288            #'(lambda ()
2289                (setf (progress-percentage pbar) 0)
2290                (setf
2291                 (progress-bar-discrete-blocks pbar)
2292                 (spin-button-value-as-int block-spin))))
2293           (setf (widget-sensitive-p block-spin) nil)
2294
2295           (let ((hbox (hbox-new nil 0)))
2296             (box-pack-start hbox block-spin nil t 0)
2297             (table-attach table hbox 1 2 4 5 :x-padding 5 :y-padding 5)))
2298
2299         (let* ((step-size-adj (adjustment-new 3 1 20 1 5 0))
2300                (step-size-spin (spin-button-new step-size-adj 0 0))
2301                (block-adj (adjustment-new 5 2 10 1 5 00))
2302                (block-spin (spin-button-new block-adj 0 0)))
2303
2304         (let ((button (check-button-new "Activity mode")))
2305           (signal-connect
2306            button 'clicked
2307            #'(lambda ()
2308                (let ((state (toggle-button-active-p button)))
2309                  (setf (progress-activity-mode-p pbar) state)
2310                  (setf (widget-sensitive-p step-size-spin) state)
2311                  (setf (widget-sensitive-p block-spin) state))))
2312           (table-attach table button 0 1 5 6 :x-padding 5 :y-padding 5))
2313
2314         (signal-connect
2315          step-size-adj 'value-changed
2316          #'(lambda ()
2317              (setf
2318               (progress-bar-activity-step pbar)
2319               (spin-button-value-as-int step-size-spin))))
2320         (setf (widget-sensitive-p step-size-spin) nil)
2321
2322         (let ((hbox (hbox-new nil 0)))
2323           (box-pack-start hbox (label-new "Step size : ") nil t 0)
2324           (box-pack-start hbox step-size-spin nil t 0)
2325           (table-attach table hbox 1 2 5 6 :x-padding 5 :y-padding 5))
2326
2327         (signal-connect
2328          block-adj 'value-changed
2329          #'(lambda ()
2330              (setf
2331               (progress-bar-activity-blocks pbar)
2332               (spin-button-value-as-int block-spin))))
2333         (setf (widget-sensitive-p block-spin) nil)
2334
2335         (let ((hbox (hbox-new nil 0)))
2336           (box-pack-start hbox (label-new "Blocks :     ") nil t 0)
2337           (box-pack-start hbox block-spin nil t 0)
2338           (table-attach table hbox 1 2 6 7 :x-padding 5 :y-padding 5)))))))
2339
2340
2341
2342 ;;; Radio buttons
2343
2344 (define-standard-dialog create-radio-buttons "Radio buttons"
2345   (setf (container-border-width main-box) 10)
2346   (setf (box-spacing main-box) 10)
2347   (let* ((button1 (radio-button-new nil :label "button1"))
2348          (button2 (radio-button-new
2349                    (radio-button-group button1) :label "button2"))
2350          (button3 (radio-button-new
2351                    (radio-button-group button2) :label "button3")))
2352     (box-pack-start main-box button1 t t 0)
2353     (box-pack-start main-box button2 t t 0)
2354     (setf (toggle-button-active-p button2) t)
2355     (box-pack-start main-box button3 t t 0)))
2356
2357
2358
2359 ;;; Rangle controls
2360
2361 (define-standard-dialog create-range-controls "Range controls"
2362   (setf (container-border-width main-box) 10)
2363   (setf (box-spacing main-box) 10)
2364   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
2365
2366     (let ((scale (hscale-new adjustment)))
2367       (setf (widget-width scale) 150)
2368       (setf (widget-height scale) 30)
2369       (setf (range-update-policy scale) :delayed)
2370       (setf (scale-digits scale) 1)
2371       (setf (scale-draw-value-p scale) t)
2372       (box-pack-start main-box scale t t 0))
2373
2374     (let ((scrollbar (hscrollbar-new adjustment)))
2375       (setf (range-update-policy scrollbar) :continuous)
2376       (box-pack-start main-box scrollbar t t 0))))
2377
2378
2379
2380 ;;; Reparent test
2381
2382 (define-standard-dialog create-reparent "reparent"
2383   (let ((box2 (hbox-new nil 5))
2384         (label (label-new "Hellow World")))
2385     (setf (container-border-width box2) 10)
2386     (box-pack-start main-box box2 t t 0)
2387
2388     (let ((frame (frame-new "Frame 1"))
2389           (box3 (vbox-new nil 5))
2390           (button (button-new "switch")))
2391       (box-pack-start box2 frame t t 0)
2392
2393       (setf (container-border-width box3) 5)
2394       (container-add frame box3)
2395
2396       (signal-connect
2397        button 'clicked
2398        #'(lambda ()
2399            (widget-reparent label box3)))
2400       (box-pack-start box3 button nil t 0)
2401
2402       (box-pack-start box3 label nil t 0)
2403       (signal-connect
2404        label 'parent-set
2405        #'(lambda (old-parent)
2406            (declare (ignore old-parent)))))
2407
2408     (let ((frame (frame-new "Frame 2"))
2409           (box3 (vbox-new nil 5))
2410           (button (button-new "switch")))
2411       (box-pack-start box2 frame t t 0)
2412
2413       (setf (container-border-width box3) 5)
2414       (container-add frame box3)
2415
2416       (signal-connect
2417        button 'clicked
2418        #'(lambda ()
2419            (widget-reparent label box3)))
2420       (box-pack-start box3 button nil t 0))))
2421
2422
2423
2424 ;;; Rulers
2425
2426 (define-test-window create-rulers "rulers"
2427   (setf (widget-width window) 300)
2428   (setf (widget-height window) 300)
2429   (setf (widget-events window) '(:pointer-motion :pointer-motion-hint))
2430
2431   (let ((table (table-new 2 2 nil)))
2432     (container-add window table)
2433     (widget-show table)
2434
2435     (let ((ruler (hruler-new)))
2436       (setf (ruler-metric ruler) :centimeters)
2437       (ruler-set-range ruler 100 0 0 20)
2438       (signal-connect
2439        window 'motion-notify-event
2440        #'(lambda (event) (widget-event ruler event)))
2441       (table-attach table ruler 1 2 0 1 :y-options '(:fill))
2442       (widget-show ruler))
2443
2444     (let ((ruler (vruler-new)))
2445       (ruler-set-range ruler 5 15 0 20)
2446       (signal-connect
2447        window 'motion-notify-event
2448        #'(lambda (event) (widget-event ruler event)))
2449       (table-attach table ruler 0 1 1 2 :x-options '(:fill))
2450       (widget-show ruler))))
2451
2452
2453
2454 ;;; Scrolled window
2455
2456 (define-standard-dialog create-scrolled-windows "Scrolled windows"
2457   (let ((scrolled-window (scrolled-window-new nil nil)))
2458     (setf (container-border-width scrolled-window) 10)
2459     (setf (scrolled-window-scrollbar-policy scrolled-window) :automatic)
2460     (box-pack-start main-box scrolled-window t t 0)
2461
2462     (let ((table (table-new 20 20 nil)))
2463       (setf (table-row-spacings table) 10)
2464       (setf (table-column-spacings table) 10)
2465       (scrolled-window-add-with-viewport scrolled-window table)
2466       (setf
2467        (container-focus-vadjustment table)
2468        (scrolled-window-vadjustment scrolled-window))
2469       (setf
2470        (container-focus-hadjustment table)
2471        (scrolled-window-hadjustment scrolled-window))
2472
2473       (dotimes (i 20)
2474         (dotimes (j 20)
2475           (let ((button
2476                  (toggle-button-new (format nil "button (~D,~D)~%" i j))))
2477             (table-attach table button i (1+ i) j (1+ j)))))))
2478
2479   (let ((button (button-new "remove")))
2480     (signal-connect button 'clicked #'(lambda ()))
2481     (setf (widget-can-default-p button) t)
2482     (box-pack-start action-area button t t 0)
2483     (widget-grab-default button))
2484
2485   (setf (window-default-height window) 300)
2486   (setf (window-default-width window) 300))
2487
2488
2489
2490 ;;; Shapes
2491
2492 (defun shape-create-icon (xpm-file x y px py window-type root-window)
2493   (let ((window (window-new window-type))
2494         (fixed (fixed-new)))
2495     (setf (widget-width fixed) 100)
2496     (setf (widget-height fixed) 100)
2497     (container-add window fixed)
2498     (widget-show fixed)
2499
2500     (setf
2501      (widget-events window)
2502      (append
2503       (widget-events window)
2504       '(:button-motion :pointer-motion-hint :button-press)))
2505     (widget-realize window)
2506
2507     (multiple-value-bind (gdk-pixmap gdk-pixmap-mask)
2508         (gdk:pixmap-create xpm-file)
2509       (let ((pixmap (pixmap-new (list gdk-pixmap gdk-pixmap-mask)))
2510             (x-offset 0)
2511             (y-offset 0))
2512         (declare (fixnum x-offset y-offset))
2513         (fixed-put fixed pixmap px py)
2514         (widget-show pixmap)
2515         (widget-shape-combine-mask window gdk-pixmap-mask px py)
2516         (signal-connect
2517          window 'button-press-event
2518          #'(lambda (event)
2519              (when (eq (gdk:event-type event) :button-press)
2520                (setq x-offset (truncate (gdk:event-x event)))
2521                (setq y-offset (truncate (gdk:event-y event)))
2522                (grab-add window)
2523                (gdk:pointer-grab
2524                 (widget-window window) t
2525                 '(:button-release :button-motion :pointer-motion-hint)
2526                 nil nil 0))
2527              t))
2528
2529         (signal-connect
2530          window 'button-release-event
2531          #'(lambda (event)
2532              (declare (ignore event))
2533              (grab-remove window)
2534              (gdk:pointer-ungrab 0)
2535              t))
2536
2537         (signal-connect
2538          window 'motion-notify-event
2539          #'(lambda (event)
2540              (declare (ignore event))
2541              (multiple-value-bind (win xp yp mask)
2542                  (gdk:window-get-pointer root-window)
2543                (declare (ignore mask win) (fixnum xp yp))
2544                (widget-set-uposition
2545                 window :x (- xp x-offset) :y (- yp y-offset)))
2546              t))))
2547
2548     (widget-set-uposition window :x x :y y)
2549     (widget-show window)
2550     window))
2551
2552
2553 (let ((modeller nil)
2554       (sheets nil)
2555       (rings nil))
2556   (defun create-shapes ()
2557     (let ((root-window (gdk:get-root-window)))
2558       (if (not modeller)
2559           (progn
2560             (setq
2561              modeller
2562              (shape-create-icon
2563               "cl-gtk:src;Modeller.xpm"
2564               440 140 0 0 :popup root-window))
2565             (signal-connect
2566              modeller 'destroy
2567              #'(lambda () (widget-destroyed modeller))))
2568         (widget-destroy modeller))
2569
2570       (if (not sheets)
2571           (progn
2572             (setq
2573              sheets
2574              (shape-create-icon
2575               "cl-gtk:src;FilesQueue.xpm"
2576               580 170 0 0 :popup root-window))
2577             (signal-connect
2578              sheets 'destroy
2579              #'(lambda () (widget-destroyed sheets))))
2580         (widget-destroy sheets))
2581
2582       (if (not rings)
2583           (progn
2584             (setq
2585              rings
2586              (shape-create-icon
2587               "cl-gtk:src;3DRings.xpm"
2588               460 270 25 25 :toplevel root-window))
2589             (signal-connect
2590              rings 'destroy
2591              #'(lambda () (widget-destroyed rings))))
2592         (widget-destroy rings)))))
2593
2594
2595
2596 ;;; Spin buttons
2597
2598 (define-test-window create-spins "Spin buttons"
2599   (let ((main-vbox (vbox-new nil 5)))
2600     (setf (container-border-width main-vbox) 10)
2601     (container-add window main-vbox)
2602
2603     (let ((frame (frame-new "Not accelerated"))
2604           (vbox (vbox-new nil 0))
2605           (hbox (hbox-new nil 0)))
2606       (box-pack-start main-vbox frame t t 0)
2607       (setf (container-border-width vbox) 5)
2608       (container-add frame vbox)
2609       (box-pack-start vbox hbox t t 5)
2610
2611       (let* ((vbox2 (vbox-new nil 0))
2612              (label (label-new "Day :"))
2613              (spinner (spin-button-new
2614                        (adjustment-new 1 1 31 1 5 0) 0 0)))
2615         (box-pack-start hbox vbox2 t t 5)
2616         (setf (misc-xalign label) 0)
2617         (setf (misc-yalign label) 0.5)
2618         (box-pack-start vbox2 label nil t 0)
2619         (setf (spin-button-wrap-p spinner) t)
2620         (setf (spin-button-shadow-type spinner) :out)
2621         (box-pack-start vbox2 spinner nil t 0))
2622
2623       (let* ((vbox2 (vbox-new nil 0))
2624              (label (label-new "Month :"))
2625              (spinner (spin-button-new
2626                        (adjustment-new 1 1 12 1 5 0) 0 0)))
2627         (box-pack-start hbox vbox2 t t 5)
2628         (setf (misc-xalign label) 0)
2629         (setf (misc-yalign label) 0.5)
2630         (box-pack-start vbox2 label nil t 0)
2631         (setf (spin-button-wrap-p spinner) t)
2632         (setf (spin-button-shadow-type spinner) :etched-in)
2633         (box-pack-start vbox2 spinner nil t 0))
2634
2635       (let* ((vbox2 (vbox-new nil 0))
2636              (label (label-new "Year :"))
2637              (spinner (spin-button-new
2638                        (adjustment-new 1998 0 2100 1 100 0) 0 0)))
2639         (box-pack-start hbox vbox2 t t 5)
2640         (setf (misc-xalign label) 0)
2641         (setf (misc-yalign label) 0.5)
2642         (box-pack-start vbox2 label nil t 0)
2643         (setf (spin-button-wrap-p spinner) t)
2644         (setf (spin-button-shadow-type spinner) :in)
2645         (box-pack-start vbox2 spinner nil t 0)))
2646
2647     (let* ((frame (frame-new "Accelerated"))
2648            (vbox (vbox-new nil 0))
2649            (hbox (hbox-new nil 0))
2650            (spinner1 (spin-button-new
2651                       (adjustment-new 0 -10000 10000 0.5 100 0) 1.0 2))
2652            (adj (adjustment-new 2 1 5 1 1 0))
2653            (spinner2 (spin-button-new adj 1.0 0)))
2654
2655       (box-pack-start main-vbox frame t t 0)
2656       (setf (container-border-width vbox) 5)
2657       (container-add frame vbox)
2658       (box-pack-start vbox hbox nil t 5)
2659
2660       (let* ((vbox2 (vbox-new nil 0))
2661              (label (label-new "Value :")))
2662         (box-pack-start hbox vbox2 t t 5)
2663         (setf (misc-xalign label) 0)
2664         (setf (misc-yalign label) 0.5)
2665         (box-pack-start vbox2 label nil t 0)
2666         (setf (spin-button-wrap-p spinner1) t)
2667         (setf (widget-width spinner1) 100)
2668         (setf (widget-height spinner1) 0)
2669         (box-pack-start vbox2 spinner1 nil t 0))
2670
2671       (let* ((vbox2 (vbox-new nil 0))
2672              (label (label-new "Digits :")))
2673         (box-pack-start hbox vbox2 t t 5)
2674         (setf (misc-xalign label) 0)
2675         (setf (misc-yalign label) 0.5)
2676         (box-pack-start vbox2 label nil t 0)
2677         (setf (spin-button-wrap-p spinner2) t)
2678         (signal-connect adj 'value-changed
2679                         #'(lambda ()
2680                             (setf
2681                              (spin-button-digits spinner1)
2682                              (floor (spin-button-value spinner2)))))
2683         (box-pack-start vbox2 spinner2 nil t 0))
2684
2685       (let ((button (check-button-new "Snap to 0.5-ticks")))
2686         (signal-connect button 'clicked
2687                         #'(lambda ()
2688                             (setf
2689                              (spin-button-snap-to-ticks-p spinner1)
2690                              (toggle-button-active-p button))))
2691         (box-pack-start vbox button t t 0)
2692         (setf (toggle-button-active-p button) t))
2693
2694       (let ((button (check-button-new "Numeric only input mode")))
2695         (signal-connect button 'clicked
2696                         #'(lambda ()
2697                             (setf
2698                              (spin-button-numeric-p spinner1)
2699                              (toggle-button-active-p button))))
2700         (box-pack-start vbox button t t 0)
2701         (setf (toggle-button-active-p button) t))
2702
2703       (let ((val-label (label-new "0"))
2704             (hbox (hbox-new nil 0)))
2705         (box-pack-start vbox hbox nil t 5)
2706         (let ((button (button-new "Value as Int")))
2707           (signal-connect
2708            button 'clicked
2709            #'(lambda ()
2710                (setf
2711                 (label-text val-label)
2712                 (format nil "~D" (spin-button-value-as-int spinner1)))))
2713           (box-pack-start hbox button t t 5))
2714
2715         (let ((button (button-new "Value as Float")))
2716           (signal-connect
2717            button 'clicked
2718            #'(lambda ()
2719                (setf
2720                 (label-text val-label)
2721                 (format nil
2722                         (format nil "~~,~DF" (spin-button-digits spinner1))
2723                         (spin-button-value spinner1)))))
2724           (box-pack-start hbox button t t 5))
2725
2726         (box-pack-start vbox val-label t t 0)))
2727
2728     (let ((hbox (hbox-new nil 0))
2729           (button (button-new "Close")))
2730       (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
2731       (box-pack-start main-vbox hbox nil t 0)
2732       (box-pack-start hbox button t t 5))))
2733
2734
2735
2736 ;;; Statusbar
2737
2738 (define-test-window create-statusbar "Statusbar"
2739   (let ((box1 (vbox-new nil 0)))
2740     (container-add window box1)
2741
2742     (let ((box2 (vbox-new nil 10))
2743           (statusbar (statusbar-new))
2744           (statusbar-counter 0))
2745       (setf (container-border-width box2) 10)
2746       (box-pack-start box1 box2 t t 0)
2747       (box-pack-end box1 statusbar t t 0)
2748       (signal-connect
2749        statusbar 'text-popped
2750        #'(lambda (context-id text)
2751            (declare (ignore context-id))
2752            (format nil "Popped: ~A~%" text)))
2753
2754       (make-button
2755        :label "push something"
2756        :visible t
2757        :parent box2
2758        :signal (list
2759                  'clicked
2760                  #'(lambda ()
2761                      (statusbar-push
2762                       statusbar
2763                       1
2764                       (format nil "something ~D" (incf statusbar-counter))))))
2765
2766       (make-button
2767        :label "pop"
2768        :visible t
2769        :parent box2
2770        :signal (list
2771                 'clicked
2772                 #'(lambda ()
2773                     (statusbar-pop statusbar 1))
2774                 :after t))
2775
2776       (make-button
2777        :label "steal #4"
2778        :visible t
2779        :parent box2
2780        :signal (list
2781                 'clicked
2782                 #'(lambda ()
2783                     (statusbar-remove statusbar 1 4))
2784                 :after t))
2785
2786       (make-button :label "test contexts"
2787                    :visible t
2788                    :parent box2
2789                    :signal (list 'clicked #'(lambda ()))))
2790
2791     (box-pack-start box1 (hseparator-new) nil t 0)
2792
2793     (let ((box2 (vbox-new nil 10)))
2794       (setf (container-border-width box2) 10)
2795       (box-pack-start box1 box2 nil t 0)
2796
2797       (let ((button (button-new "close")))
2798         (signal-connect button 'clicked #'(lambda () (widget-destroy window)))
2799         (box-pack-start box2 button t t 0)
2800         (setf (widget-can-default-p button) t)
2801         (widget-grab-default button)))))
2802
2803
2804
2805 ;;; Idle test
2806
2807 (define-standard-dialog create-idle-test "Idle Test"
2808   (let ((label (label-new "count: 0"))
2809         (idle nil)
2810         (count 0))
2811     (declare (fixnum count))
2812     (signal-connect
2813      window 'destroy #'(lambda () (when idle (idle-remove idle))))
2814
2815     (setf (misc-xpad label) 10)
2816     (setf (misc-ypad label) 10)
2817     (box-pack-start main-box label t t 0)
2818
2819     (let* ((container (make-hbox :parent main-box :child label :visible t))
2820            (frame (make-frame
2821                    :border-width 5
2822                    :label "Label Container"
2823                    :visible t
2824                    :parent main-box))
2825            (box (make-vbox :visible t :parent frame)))
2826       (make-check-button
2827        :label "Resize-Parent"
2828        :visible t
2829        :parent box
2830        :signal
2831        (list
2832         'clicked
2833         #'(lambda ()
2834             (setf (container-resize-mode container) :parent))))
2835
2836       (make-check-button
2837        :label "Resize-Queue"
2838        :visible t
2839        :parent box
2840        :signal
2841        (list
2842         'clicked
2843         #'(lambda ()
2844             (setf (container-resize-mode container) :queue))))
2845
2846       (make-check-button
2847        :label "Resize-Immediate"
2848        :visible t
2849        :parent box
2850        :signal
2851        (list
2852         'clicked
2853         #'(lambda ()
2854             (setf (container-resize-mode container) :immediate)))))
2855
2856     (let ((button (button-new "start")))
2857       (signal-connect
2858        button 'clicked
2859        #'(lambda ()
2860        (unless idle
2861          (setq
2862           idle
2863           (idle-add
2864            #'(lambda ()
2865                (incf count)
2866                (setf (label-text label) (format nil "count: ~D" count))
2867                t))))))
2868       (setf (widget-can-default-p button) t)
2869       (box-pack-start action-area button t t 0)
2870       (widget-show button))
2871
2872     (let ((button (button-new "stop")))
2873       (signal-connect
2874        button 'clicked
2875        #'(lambda ()
2876        (when idle
2877          (idle-remove idle)
2878          (setq idle nil))))
2879       (setf (widget-can-default-p button) t)
2880       (box-pack-start action-area button t t 0)
2881       (widget-show button))))
2882
2883
2884
2885 ;;; Timeout test
2886
2887 (define-standard-dialog create-timeout-test "Timeout Test"
2888   (let ((label (label-new "count: 0"))
2889         (timer nil)
2890         (count 0))
2891     (declare (fixnum count))
2892     (signal-connect
2893      window 'destroy #'(lambda () (when timer (timeout-remove timer))))
2894
2895     (setf (misc-xpad label) 10)
2896     (setf (misc-ypad label) 10)
2897     (box-pack-start main-box label t t 0)
2898     (widget-show label)
2899
2900     (let ((button (button-new "start")))
2901       (signal-connect
2902        button 'clicked
2903        #'(lambda ()
2904        (unless timer
2905          (setq
2906           timer
2907           (timeout-add
2908            100
2909            #'(lambda ()
2910                (incf count)
2911                (setf (label-text label) (format nil "count: ~D" count))
2912                t))))))
2913       (setf (widget-can-default-p button) t)
2914       (box-pack-start action-area button t t 0)
2915       (widget-show button))
2916
2917     (let ((button (button-new "stop")))
2918       (signal-connect
2919        button 'clicked
2920        #'(lambda ()
2921        (when timer
2922          (timeout-remove timer)
2923          (setq timer nil))))
2924       (setf (widget-can-default-p button) t)
2925       (box-pack-start action-area button t t 0)
2926       (widget-show button))))
2927
2928
2929
2930 ;;; Text
2931
2932 (define-test-window create-text "Text"
2933   (setf (widget-name window) "text window")
2934   (setf (widget-width window) 500)
2935   (setf (widget-height window) 500)
2936   (setf (window-allow-grow-p window) t)
2937   (setf (window-allow-shrink-p window) t)
2938   (setf (window-auto-shrink-p window) nil)
2939   (let ((box1 (vbox-new nil 0)))
2940     (container-add window box1)
2941
2942     (let ((box2 (vbox-new nil 10)))
2943       (setf (container-border-width box2) 10)
2944       (box-pack-start box1 box2 t t 0)
2945
2946       (let ((scrolled-window (scrolled-window-new))
2947             (text (text-new)))
2948         (box-pack-start box2 scrolled-window t t 0)
2949         (setf (scrolled-window-hscrollbar-policy scrolled-window) :never)
2950         (setf (scrolled-window-vscrollbar-policy scrolled-window) :always)
2951         (setf (editable-editable-p text) t)
2952         (container-add scrolled-window text)
2953         (widget-grab-focus text)
2954
2955         (text-freeze text)
2956         (let ((font
2957                (gdk:font-load
2958                 "-adobe-courier-medium-r-normal--*-120-*-*-*-*-*-*"))
2959               (colors
2960                (map 'list
2961                     #'(lambda (definition)
2962                         (cons
2963                          (gdk:color-new-from-vector (first definition))
2964                          (second definition)))
2965                     '((#(#x0000 #x0000 #x0000) "black")
2966                       (#(#xFFFF #xFFFF #xFFFF) "white")
2967                       (#(#xFFFF #x0000 #x0000) "red")
2968                       (#(#x0000 #xFFFF #x0000) "green")
2969                       (#(#x0000 #x0000 #xFFFF) "blue")
2970                       (#(#x0000 #xFFFF #xFFFF) "cyan")
2971                       (#(#xFFFF #x0000 #xFFFF) "magneta")
2972                       (#(#xFFFF #xFFFF #x0000) "yellow")))))
2973           (dolist (color1 colors)
2974             (text-insert text (format nil "~A~,7T" (cdr color1)) :font font)
2975             (dolist (color2 colors)
2976               (text-insert
2977                text "XYZ" :font font
2978                :foreground (car color2) :background (car color1)))
2979             (text-insert text (format nil "~%")))
2980           (dolist (color colors)
2981             (gdk:color-destroy (car color)))
2982           (gdk:font-unref font))
2983
2984         (with-open-file (file "cl-gtk:src;testgtk.lisp")
2985           (labels ((read-file ()
2986                      (let ((line (read-line file nil nil)))
2987                        (when line
2988                          (text-insert text (format nil "~A~%" line))
2989                          (read-file)))))
2990             (read-file)))
2991
2992         (text-thaw text)
2993
2994         (let ((hbox (hbutton-box-new)))
2995           (box-pack-start box2 hbox nil nil 0)
2996           (let ((check-button (check-button-new "Editable")))
2997             (box-pack-start hbox check-button nil nil 0)
2998             (signal-connect
2999              check-button 'toggled
3000              #'(lambda ()
3001                  (setf
3002                   (editable-editable-p text)
3003                   (toggle-button-active-p check-button))))
3004             (setf (toggle-button-active-p check-button) t))
3005
3006           (let ((check-button (check-button-new "Wrap Words")))
3007             (box-pack-start hbox check-button nil t 0)
3008             (signal-connect
3009              check-button 'toggled
3010              #'(lambda ()
3011                  (setf
3012                   (text-word-wrap-p text)
3013                   (toggle-button-active-p check-button))))
3014             (setf (toggle-button-active-p check-button) nil)))))
3015
3016     (box-pack-start box1 (hseparator-new) nil t 0)
3017
3018     (let ((box2 (vbox-new nil 10)))
3019       (setf (container-border-width box2) 10)
3020       (box-pack-start box1 box2 nil t 0)
3021
3022       (let ((button (button-new "insert random")))
3023         (signal-connect button 'clicked #'(lambda () nil))
3024         (box-pack-start box2 button t t 0))
3025
3026       (let ((button (button-new "close")))
3027         (signal-connect
3028          button 'clicked
3029          #'(lambda ()
3030              (widget-destroy window)
3031              (setq window nil)))
3032         (box-pack-start box2 button t t 0)
3033         (setf (widget-can-default-p button) t)
3034         (widget-grab-default button)))))
3035
3036
3037
3038 ;;; Toggle buttons
3039
3040 (define-standard-dialog create-toggle-buttons "Toggle Button"
3041   (setf (container-border-width main-box) 10)
3042   (setf (box-spacing main-box) 10)
3043   (box-pack main-box (toggle-button-new "button1"))
3044   (box-pack main-box (toggle-button-new "button2"))
3045   (box-pack main-box (toggle-button-new "button3")))
3046
3047
3048
3049 ;;; Toolbar test
3050
3051 (define-test-window create-toolbar "Toolbar test"
3052   (setf (window-allow-grow-p window) nil)
3053   (setf (window-allow-shrink-p window) t)
3054   (setf (window-auto-shrink-p window) t)
3055   (widget-realize window)
3056
3057
3058   (let ((toolbar (toolbar-new :horizontal :both)))
3059     (setf (toolbar-relief toolbar) :none)
3060
3061     (toolbar-append-item
3062      toolbar "Horizontal" (pixmap-new "cl-gtk:src;test.xpm")
3063      :tooltip-text "Horizontal toolbar layout"
3064      :tooltip-private-text "Toolbar/Horizontal"
3065      :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
3066
3067     (toolbar-append-item
3068      toolbar "Vertical" (pixmap-new "cl-gtk:src;test.xpm")
3069      :tooltip-text "Vertical toolbar layout"
3070      :tooltip-private-text "Toolbar/Vertical"
3071      :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
3072
3073     (toolbar-append-space toolbar)
3074
3075     (toolbar-append-item
3076      toolbar "Icons" (pixmap-new "cl-gtk:src;test.xpm")
3077      :tooltip-text "Only show toolbar icons"
3078      :tooltip-private-text "Toolbar/IconsOnly"
3079      :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
3080
3081     (toolbar-append-item
3082      toolbar "Text" (pixmap-new "cl-gtk:src;test.xpm")
3083      :tooltip-text "Only show toolbar text"
3084      :tooltip-private-text "Toolbar/TextOnly"
3085      :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
3086
3087     (toolbar-append-item
3088      toolbar "Both" (pixmap-new "cl-gtk:src;test.xpm")
3089      :tooltip-text "Show toolbar icons and text"
3090      :tooltip-private-text "Toolbar/Both"
3091      :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
3092
3093     (toolbar-append-space toolbar)
3094
3095     (toolbar-append-widget
3096      toolbar (entry-new)
3097      :tooltip-text "This is an unusable GtkEntry ;)"
3098      :tooltip-private-text "Hey don't click me!")
3099
3100     (toolbar-append-space toolbar)
3101
3102     (toolbar-append-item
3103      toolbar "Small" (pixmap-new "cl-gtk:src;test.xpm")
3104      :tooltip-text "Use small spaces"
3105      :tooltip-private-text "Toolbar/Small"
3106      :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
3107
3108     (toolbar-append-item
3109      toolbar "Big" (pixmap-new "cl-gtk:src;test.xpm")
3110      :tooltip-text "Use big spaces"
3111      :tooltip-private-text "Toolbar/Big"
3112      :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
3113
3114     (toolbar-append-space toolbar)
3115
3116     (toolbar-append-item
3117      toolbar "Enable" (pixmap-new "cl-gtk:src;test.xpm")
3118      :tooltip-text "Enable tooltips"
3119      :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
3120
3121     (toolbar-append-item
3122      toolbar "Disable" (pixmap-new "cl-gtk:src;test.xpm")
3123      :tooltip-text "Disable tooltips"
3124      :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
3125
3126     (toolbar-append-space toolbar)
3127
3128     (toolbar-append-item
3129      toolbar "Borders" (pixmap-new "cl-gtk:src;test.xpm")
3130      :tooltip-text "Show borders"
3131      :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
3132
3133     (toolbar-append-item
3134      toolbar
3135      "Borderless" (pixmap-new "cl-gtk:src;test.xpm")
3136      :tooltip-text "Hide borders"
3137      :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
3138
3139     (toolbar-append-space toolbar)
3140
3141     (toolbar-append-item
3142      toolbar "Empty" (pixmap-new "cl-gtk:src;test.xpm")
3143      :tooltip-text "Empty spaces"
3144      :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
3145
3146     (toolbar-append-item
3147      toolbar "Lines" (pixmap-new "cl-gtk:src;test.xpm")
3148      :tooltip-text "Lines in spaces"
3149      :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
3150
3151     (container-add window toolbar)))
3152
3153
3154
3155 ;;; Tooltips test
3156
3157 (define-standard-dialog create-tooltips "Tooltips"
3158   (setf (window-allow-grow-p window) t)
3159   (setf (window-allow-shrink-p window) nil)
3160   (setf (window-auto-shrink-p window) t)
3161   (setf (widget-width window) 200)
3162   (setf (container-border-width main-box) 10)
3163   (setf (box-spacing main-box) 10)
3164
3165   (let ((tooltips (tooltips-new)))
3166
3167     (let ((button (toggle-button-new "button1")))
3168       (box-pack-start main-box button t t 0)
3169       (tooltips-set-tip
3170        tooltips button "This is button 1" "ContextHelp/button/1"))
3171
3172     (let ((button (toggle-button-new "button2")))
3173       (box-pack-start main-box button t t 0)
3174       (tooltips-set-tip
3175        tooltips button "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."
3176        "ContextHelp/button/2"))
3177
3178     (let ((toggle (toggle-button-new "Override TipSQuery Label")))
3179       (box-pack-start main-box toggle t t 0)
3180       (tooltips-set-tip
3181        tooltips toggle "Toggle TipsQuery view" "Hi msw! ;)")
3182
3183       (let* ((box3 (make-vbox
3184                     :homogeneous nil
3185                     :spacing 5
3186                     :border-width 5
3187                     :visible t))
3188              (tips-query (make-tips-query
3189                           :visible t
3190                           :parent box3))
3191              (button (make-button
3192                       :label "[?]"
3193                       :visible t
3194                       :parent box3
3195                       :signal (list
3196                                'clicked #'tips-query-start-query
3197                                :object tips-query))))
3198
3199         (box-set-child-packing box3 button nil nil 0 :start)
3200         (tooltips-set-tip
3201          tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
3202         (setf (tips-query-caller tips-query) button)
3203
3204         (signal-connect
3205          tips-query 'widget-entered
3206          #'(lambda (widget tip-text tip-private)
3207              (declare (ignore widget tip-private))
3208              (when (toggle-button-active-p toggle)
3209                (setf
3210                 (label-text tips-query)
3211                 (if tip-text
3212                     "There is a Tip!"
3213                   "There is no Tip!"))
3214                (signal-emit-stop tips-query 'widget-entered))))
3215
3216         (signal-connect
3217          tips-query 'widget-selected
3218          #'(lambda (widget tip-text tip-private event)
3219              (declare (ignore tip-text event))
3220              (when widget
3221                (format
3222                 t "Help ~S requested for ~S~%"
3223                 (or tip-private "None") (type-of widget)))
3224              t))
3225
3226         (let ((frame (make-frame
3227                       :label "ToolTips Inspector"
3228                       :label-xalign 0.5
3229                       :border-width 0
3230                       :visible t
3231                       :parent main-box
3232                       :child box3)))
3233           (box-set-child-packing main-box frame t t 0 :start))
3234
3235         (tooltips-set-tip
3236          tooltips close-button "Push this button to close window"
3237          "ContextHelp/buttons/Close")))))
3238
3239
3240
3241 ;;; Tree
3242
3243 (defconstant +default-number-of-items+ 3)
3244 (defconstant +default-recursion-level+ 3)
3245
3246 (defun create-subtree (item level nb-item-max recursion-level-max)
3247   (unless (and level (= level recursion-level-max))
3248     (multiple-value-bind (level item-subtree no-root-item)
3249         (if (not level)
3250             (values 0 item t)
3251           (values level (tree-new) nil))
3252
3253       (dotimes (nb-item nb-item-max)
3254         (let ((new-item
3255                (tree-item-new (format nil "item ~D-~D" level nb-item))))
3256           (tree-append item-subtree new-item)
3257           (create-subtree
3258            new-item (1+ level) nb-item-max recursion-level-max)
3259           (widget-show new-item)))
3260
3261       (unless no-root-item
3262         (setf (tree-item-subtree item) item-subtree)))))
3263
3264
3265 (defun create-tree-sample (selection-mode draw-line view-line no-root-item
3266                            nb-item-max recursion-level-max)
3267   (let ((window (window-new :toplevel)))
3268     (setf (window-title window) "Tree Sample")
3269     (signal-connect window 'destroy #'(lambda ()))
3270
3271     (let ((box1 (vbox-new nil 0))
3272           (root-tree (tree-new))
3273           (add-button (button-new "Add Item"))
3274           (remove-button (button-new "Remove Item(s)"))
3275           (subtree-button (button-new "Remove Subtree")))
3276       (container-add window box1)
3277       (widget-show box1)
3278
3279       (let ((box2 (vbox-new nil 0))
3280             (scrolled-win (scrolled-window-new nil nil)))
3281         (box-pack box1 box2)
3282         (setf (container-border-width box2) 5)
3283         (widget-show box2)
3284         (setf (scrolled-window-scrollbar-policy scrolled-win) :automatic)
3285         (box-pack box2 scrolled-win)
3286         (setf (widget-width scrolled-win) 200)
3287         (setf (widget-height scrolled-win) 200)
3288         (widget-show scrolled-win)
3289         (signal-connect
3290          root-tree 'selection-changed
3291          #'(lambda ()
3292              (format t "Selection: ~A~%" (tree-selection root-tree))
3293              (let ((nb-selected (length (tree-selection root-tree))))
3294                (if (zerop nb-selected)
3295                    (progn
3296                      (if (container-children root-tree)
3297                          (setf (widget-sensitive-p add-button) t)
3298                        (setf (widget-sensitive-p add-button) nil))
3299                      (setf (widget-sensitive-p remove-button) nil)
3300                      (setf (widget-sensitive-p subtree-button) nil))
3301                  (progn
3302                    (setf (widget-sensitive-p remove-button) t)
3303                    (setf (widget-sensitive-p add-button) (= 1 nb-selected))
3304                    (setf
3305                     (widget-sensitive-p subtree-button) (= 1 nb-selected)))))))
3306         (scrolled-window-add-with-viewport scrolled-win root-tree)
3307         (setf (tree-selection-mode root-tree) selection-mode)
3308         (setf (tree-view-lines-p root-tree) draw-line)
3309         (setf (tree-view-mode root-tree) (if view-line :line :item))
3310         (widget-show root-tree)
3311
3312         (let ((root-item
3313                (if no-root-item
3314                    root-tree
3315                  (let ((root-item (tree-item-new "root item")))
3316                    (tree-append root-tree root-item)
3317                    (widget-show root-item)
3318                    root-item))))
3319           (create-subtree
3320            root-item (if no-root-item nil 0) nb-item-max recursion-level-max)))
3321
3322       (let ((box2 (vbox-new nil 0)))
3323         (box-pack-start box1 box2 nil nil 0)
3324         (setf (container-border-width box2) 5)
3325         (widget-show box2)
3326
3327         (setf (widget-sensitive-p add-button) nil)
3328         (let ((nb-item-add 0))
3329           (signal-connect
3330            add-button 'clicked
3331            #'(lambda ()
3332                (let* ((selected-list (tree-selection root-tree))
3333                       (subtree (if (not selected-list)
3334                                    root-tree
3335                                  (let ((selected-item (first selected-list)))
3336                                    (or
3337                                     (tree-item-subtree selected-item)
3338                                     (let ((subtree (tree-new)))
3339                                       (setf
3340                                        (tree-item-subtree selected-item)
3341                                        subtree)
3342                                       subtree)))))
3343                       (new-item
3344                        (tree-item-new (format nil "item add ~D" nb-item-add))))
3345                  (tree-append subtree new-item)
3346                  (widget-show new-item)
3347                  (incf nb-item-add)))))
3348         (box-pack-start box2 add-button t t 0)
3349         (widget-show add-button)
3350
3351         (setf (widget-sensitive-p remove-button) nil)
3352         (signal-connect
3353          remove-button 'clicked
3354          #'(lambda ()
3355              (format t "Remove: ~A~%" (tree-selection root-tree))
3356              (tree-remove-items root-tree (tree-selection root-tree))))
3357         (box-pack-start box2 remove-button t t 0)
3358         (widget-show remove-button)
3359
3360         (setf (widget-sensitive-p subtree-button) nil)
3361         (signal-connect
3362          subtree-button 'clicked
3363          #'(lambda ()
3364              (let ((selected-list (tree-selection root-tree)))
3365                (when selected-list
3366                  (let ((item (first selected-list)))
3367                    (when item
3368                      (setf (tree-item-subtree item) nil)))))))
3369         (box-pack-start box2 subtree-button t t 0)
3370         (widget-show subtree-button))
3371
3372       (let ((separator (hseparator-new)))
3373         (box-pack-start box1 separator nil nil 0)
3374         (widget-show separator))
3375
3376       (let ((box2 (vbox-new nil 0))
3377             (button (button-new "Close")))
3378         (box-pack-start box1 box2 nil nil 0)
3379         (setf (container-border-width box2) 5)
3380         (widget-show box2)
3381         (box-pack-start box2 button t t 0)
3382         (signal-connect button 'clicked
3383                         #'(lambda ()
3384                             (widget-destroy window)))
3385         (widget-show button)))
3386
3387     (widget-show window)))
3388
3389
3390 (define-test-window create-tree "Set Tree Parameters"
3391   (let ((box1 (vbox-new nil 0)))
3392     (container-add window box1)
3393
3394     (let ((box2 (vbox-new nil 5)))
3395       (box-pack box1 box2)
3396       (setf (container-border-width box2) 5)
3397
3398       (let ((box3 (hbox-new nil 5)))
3399         (box-pack box2 box3)
3400
3401         (let* ((single-button (radio-button-new nil :label "SIGNLE"))
3402                (browse-button
3403                 (radio-button-new
3404                  (radio-button-group single-button) :label "BROWSE"))
3405                (multiple-button
3406                 (radio-button-new
3407                  (radio-button-group single-button) :label "MULTIPLE"))
3408                (draw-line-button (check-button-new "Draw line"))
3409                (view-line-button (check-button-new "View Line mode"))
3410                (no-root-item-button (check-button-new "Without Root item"))
3411                (num-of-items-spinner
3412                 (spin-button-new
3413                  (adjustment-new
3414                   +default-number-of-items+ 1 255 1 5 0)
3415                  0 0))
3416                (depth-spinner
3417                 (spin-button-new
3418                  (adjustment-new
3419                   +default-recursion-level+ 0 255 1 5 0)
3420                  5 0)))
3421
3422           (let ((frame (frame-new "Selection Mode"))
3423                 (box4 (vbox-new nil 0)))
3424             (box-pack box3 frame)
3425             (container-add frame box4)
3426             (setf (container-border-width box4) 5)
3427             (box-pack box4 single-button)
3428             (box-pack box4 browse-button)
3429             (box-pack box4 multiple-button))
3430
3431           (let ((frame (frame-new "Options"))
3432                 (box4 (vbox-new nil 0)))
3433             (box-pack box3 frame)
3434             (container-add frame box4)
3435             (setf (container-border-width box4) 5)
3436             (box-pack box4 draw-line-button)
3437             (box-pack box4 view-line-button)
3438             (box-pack box4 no-root-item-button)
3439             (setf (toggle-button-active-p draw-line-button) t)
3440             (setf (toggle-button-active-p view-line-button) t)
3441             (setf (toggle-button-active-p no-root-item-button) nil))
3442
3443           (let ((frame (frame-new "Size Parameters"))
3444                 (box4 (vbox-new nil 5)))
3445             (box-pack box2 frame)
3446             (container-add frame box4)
3447             (setf (container-border-width box4) 5)
3448
3449             (let ((box5 (hbox-new nil 5)))
3450               (box-pack box4 box5 :expand nil :fill nil)
3451               (let ((label (label-new "Number of items : ")))
3452                 (setf (misc-xalign label) 0)
3453                 (setf (misc-yalign label) 0.5)
3454                 (box-pack box5 label :expand nil)
3455                 (box-pack box5 num-of-items-spinner :expand nil))
3456               (let ((label (label-new "Depth : ")))
3457                 (setf (misc-xalign label) 0)
3458                 (setf (misc-yalign label) 0.5)
3459                 (box-pack box5 label :expand nil)
3460                 (box-pack box5 depth-spinner :expand nil))))
3461
3462           (box-pack box1 (hseparator-new) :expand nil :fill nil)
3463
3464           (let ((box2 (hbox-new t 10)))
3465             (box-pack box1 box2)
3466             (setf (container-border-width box2) 5)
3467             (let ((button (button-new "Create Tree")))
3468               (box-pack box2 button)
3469               (signal-connect
3470                button 'clicked
3471                #'(lambda ()
3472                    (let ((selection-mode
3473                           (cond
3474                            ((toggle-button-active-p single-button) :single)
3475                            ((toggle-button-active-p browse-button) :browse)
3476                            (t :multiple)))
3477                          (draw-line
3478                           (toggle-button-active-p draw-line-button))
3479                          (view-line
3480                           (toggle-button-active-p view-line-button))
3481                          (no-root-item
3482                           (toggle-button-active-p no-root-item-button))
3483                          (num-of-items
3484                           (spin-button-value-as-int num-of-items-spinner))
3485                          (depth
3486                           (spin-button-value-as-int depth-spinner)))
3487
3488                      (if (> (expt num-of-items depth) 10000)
3489                          (format t "~D total items? That will take a very long time. Try less~%" (expt num-of-items depth))
3490                        (create-tree-sample
3491                         selection-mode draw-line view-line no-root-item
3492                         num-of-items depth))))))
3493             (let ((button (button-new "Close")))
3494               (box-pack box2 button)
3495               (signal-connect
3496                button 'clicked #'widget-destroy :object window))))))))
3497
3498
3499
3500 ;;; Main window
3501
3502 (defun create-main-window ()
3503   (let* ((buttons
3504           '(("button box" create-button-box)
3505             ("buttons" create-buttons)
3506             ("calendar" create-calendar)
3507             ("check buttons" create-check-buttons)
3508             ("clist" create-clist)
3509             ("color selection" create-color-selection)
3510             ("ctree" create-ctree)
3511             ("cursors" create-cursors)
3512             ("dialog" create-dialog)
3513 ;           ("dnd")
3514             ("entry" create-entry)
3515             ("event watcher")
3516             ("file selection" create-file-selection)
3517             ("font selection")
3518             ("gamma curve")
3519             ("handle box" create-handle-box)
3520             ("item factory")
3521             ("labels" create-labels)
3522             ("layout" create-layout)
3523             ("list" create-list)
3524             ("menus" create-menus)
3525             ("modal window")
3526             ("notebook" create-notebook)
3527             ("panes" create-panes)
3528             ("pixmap" create-pixmap)
3529             ("preview color")
3530             ("preview gray")
3531             ("progress bar" create-progress-bar)
3532             ("radio buttons" create-radio-buttons)
3533             ("range controls" create-range-controls)
3534             ("rc file")
3535             ("reparent" create-reparent)
3536             ("rulers" create-rulers)
3537             ("saved position")
3538             ("scrolled windows" create-scrolled-windows)
3539             ("shapes" create-shapes)
3540             ("spinbutton" create-spins)
3541             ("statusbar" create-statusbar)
3542             ("test idle" create-idle-test)
3543             ("test mainloop")
3544             ("test scrolling")
3545             ("test selection")
3546             ("test timeout" create-timeout-test)
3547             ("text" create-text)
3548             ("toggle buttons" create-toggle-buttons)
3549             ("toolbar" create-toolbar)
3550             ("tooltips" create-tooltips)
3551             ("tree" create-tree)
3552             ("WM hints")))
3553          (main-window (make-instance 'window
3554                         :type :toplevel :title "testgtk.lisp"
3555                         :name "main window" :x 20 :y 20 :width 200 :height 400
3556                         :allow-grow nil :allow-shrink nil :auto-shrink nil))
3557          (scrolled-window (make-instance 'scrolled-window
3558                            :hscrollbar-policy :automatic
3559                            :vscrollbar-policy :automatic
3560                            :border-width 10))
3561          (close-button (make-instance 'button
3562                         :label "close"
3563                         :can-default t ;:has-default t
3564                         :signals
3565                         (list
3566                          (list
3567                           'clicked #'widget-destroy :object main-window)))))
3568
3569     ;; Main box
3570     (make-instance 'vbox
3571      :parent main-window
3572      :children
3573      (list
3574       (list
3575        (make-instance 'label :label (gtk-version))
3576        :expand nil :fill nil)
3577       (list
3578        (make-instance 'label :label (format nil "clg CVS version"))
3579        :expand nil :fill nil)
3580       scrolled-window
3581       (list (make-instance 'hseparator) :expand nil)
3582       (list
3583        (make-instance 'vbox
3584         :homogeneous nil :spacing 10 :border-width 10
3585         :children (list (list close-button :expand t :fill t)))
3586        :expand nil)))
3587
3588     (let ((button-box
3589            (make-instance 'vbox
3590             :border-width 10
3591             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
3592             :children
3593             (map
3594              'list
3595              #'(lambda (button)
3596                  (let ((widget (make-instance 'button :label (first button))))
3597                    (if (second button)
3598                        (signal-connect widget 'clicked (second button))
3599                      (setf (widget-sensitive-p widget) nil))
3600                    widget))
3601              buttons))))
3602
3603       (scrolled-window-add-with-viewport scrolled-window button-box))
3604
3605     (widget-grab-default close-button)
3606     (widget-show-all main-window)
3607     main-window))
3608
3609 ;(gdk:rgb-init)
3610 (rc-parse "cl-gtk:src;testgtkrc2")
3611 (rc-parse "cl-gtk:src;testgtkrc")
3612
3613
3614 ;(create-main-window)
3615