mdw@git.distorted.org.uk Git - clg/blob - examples/testgtk.lisp

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