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