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