chiark - git - mdw - 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.24 2005-03-06 17:12:22 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   (file-chooser-add-filter dialog
 456    (make-instance 'file-filter :name "All files" :pattern "*"))
 457   (file-chooser-add-filter dialog
 458    (make-instance 'file-filter :name "Common Lisp source code"
 459     :patterns '("*.lisp" "*.lsp")))
 460
 461   (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
 462   (dialog-add-button dialog "gtk-ok"
 463    #'(lambda ()
 464        (if (slot-boundp dialog 'filename)
 465            (format t "Selected file: ~A~%" (file-chooser-filename dialog))
 466          (write-line "No files selected"))
 467        (widget-destroy dialog))))
 468
 469
 470 ;; Font selection dialog
 471
 472 (define-toplevel create-font-selection (window "Font Button" :resizable nil)
 473   (make-instance 'h-box
 474    :parent window :spacing 8 :border-width 8
 475    :child (make-instance 'label :label "Pick a font")
 476    :child (make-instance 'font-button
 477            :use-font t :title "Font Selection Dialog")))
 478
 479
 480 ;;; Handle box
 481
 482 (define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
 483   (make-instance 'v-box
 484    :parent window
 485    :child (create-label "Above")
 486    :child (make-instance 'h-separator)
 487    :child (make-instance 'h-box
 488            :spacing 10
 489            :child (list
 490                    (make-instance 'handle-box
 491                     :child (create-toolbar window)
 492                     :signal (list 'child-attached
 493                              #'(lambda (child)
 494                                  (format t "~A attached~%" child)))
 495                     :signal (list 'child-detached
 496                              #'(lambda (child)
 497                                  (format t "~A detached~%" child))))
 498                    :expand nil :fill :nil))
 499    :child (make-instance 'h-separator)
 500    :child (create-label "Below")))
 501
 502 ;;; Image
 503
 504 (define-toplevel create-image (window "Image" :resizable nil)
 505   (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
 506
 507
 508 ;;; Labels
 509
 510 (define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
 511   (flet ((create-label-in-frame (frame-label label-text &rest args)
 512            (list
 513             (make-instance 'frame
 514              :label frame-label
 515              :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
 516             :fill nil :expand nil)))
 517     (make-instance 'h-box
 518      :spacing 5 :parent window
 519      :child-args '(:fill nil :expand nil)
 520      :child (make-instance 'v-box
 521              :spacing 5
 522              :child (create-label-in-frame "Normal Label" "This is a Normal label")
 523              :child (create-label-in-frame "Multi-line Label"
 524 "This is a Multi-line label.
 525 Second line
 526 Third line")
 527              :child (create-label-in-frame "Left Justified Label"
 528 "This is a Left-Justified
 529 Multi-line.
 530 Third line"
 531                       :justify :left)
 532              :child (create-label-in-frame "Right Justified Label"
 533 "This is a Right-Justified
 534 Multi-line.
 535 Third line"
 536                      :justify :right))
 537      :child (make-instance 'v-box
 538              :spacing 5
 539              :child (create-label-in-frame "Line wrapped label"
 540 "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.
 541      It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. "
 542                       :wrap t)
 543
 544              :child (create-label-in-frame "Filled, wrapped label"
 545 "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.
 546     This is a new paragraph.
 547     This is another newer, longer, better paragraph.  It is coming to an end, unfortunately."
 548                       :justify :fill :wrap t)
 549
 550              :child (create-label-in-frame "Underlined label"
 551 "This label is underlined!
 552 This one is underlined (こんにちは) in quite a funky fashion"
 553                       :justify :left
 554                       :pattern  "_________________________ _ _________ _ _____ _ __ __  ___ ____ _____")))))
 555
 556
 557 ;;; Layout
 558
 559 (defun layout-expose (layout event)
 560   (when (eq (gdk:event-window event) (layout-bin-window layout))
 561     (with-slots (gdk:x gdk:y gdk:width gdk:height) event
 562       (let ((imin (truncate gdk:x 10))
 563             (imax (truncate (+ gdk:x gdk:width 9) 10))
 564             (jmin (truncate gdk:y 10))
 565             (jmax (truncate (+ gdk:y gdk:height 9) 10)))
 566
 567         (let ((window (layout-bin-window layout))
 568               (gc (style-black-gc (widget-style layout))))
 569           (loop
 570            for i from imin below imax
 571            do (loop
 572                for j from jmin below jmax
 573                unless (zerop (mod (+ i j) 2))
 574                do (gdk:draw-rectangle
 575                    window gc t (* 10 i) (* 10 j)
 576                    (1+ (mod i 10)) (1+ (mod j 10)))))))))
 577   nil)
 578
 579 (define-toplevel create-layout (window "Layout" :default-width 200
 580                                                 :default-height 200)
 581   (let ((layout (make-instance 'layout
 582                  :parent (make-instance 'scrolled-window :parent window)
 583                  :width 1600 :height 128000 :events '(:exposure)
 584                  :signal (list 'expose-event #'layout-expose :object t))))
 585
 586     (with-slots (hadjustment vadjustment) layout
 587       (setf
 588        (adjustment-step-increment hadjustment) 10.0
 589        (adjustment-step-increment vadjustment) 10.0))
 590
 591     (dotimes (i 16)
 592       (dotimes (j 16)
 593         (let ((text (format nil "Button ~D, ~D" i j)))
 594           (layout-put layout
 595            (make-instance (if (not (zerop (mod (+ i j) 2)))
 596                               'button
 597                             'label)
 598                           :label text :visible t)
 599            (* j 100) (* i 100)))))
 600
 601     (loop
 602      for i from 16 below 1280
 603      do (let ((text (format nil "Button ~D, ~D" i 0)))
 604           (layout-put layout
 605            (make-instance (if (not (zerop (mod i 2)))
 606                               'button
 607                             'label)
 608                           :label text :visible t)
 609            0 (* i 100))))))
 610
 611
 612
 613 ;;; List
 614
 615 (define-simple-dialog create-list (dialog "List" :default-height 400)
 616   (let* ((store (make-instance 'list-store
 617                  :column-types '(string int boolean)
 618                  :column-names '(:foo :bar :baz)
 619                  :initial-content '(#("First" 12321 nil)
 620                                     (:foo "Yeah" :baz t))))
 621          (tree (make-instance 'tree-view :model store)))
 622
 623     (loop
 624      with iter = (make-instance 'tree-iter)
 625      for i from 1 to 1000
 626      do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
 627
 628     (let ((column (make-instance 'tree-view-column :title "Column 1"))
 629           (cell (make-instance 'cell-renderer-text)))
 630       (cell-layout-pack column cell :expand t)
 631       (cell-layout-add-attribute column cell 'text (column-index store :foo))
 632       (tree-view-append-column tree column))
 633
 634     (let ((column (make-instance 'tree-view-column :title "Column 2"))
 635           (cell (make-instance 'cell-renderer-text :background "orange")))
 636       (cell-layout-pack column cell :expand t)
 637       (cell-layout-add-attribute column cell 'text (column-index store :bar))
 638       (tree-view-append-column tree column))
 639
 640     (let ((column (make-instance 'tree-view-column :title "Column 3"))
 641           (cell (make-instance 'cell-renderer-text)))
 642       (cell-layout-pack column cell :expand t)
 643       (cell-layout-add-attribute column cell 'text (column-index store :baz))
 644       (tree-view-append-column tree column))
 645
 646     (make-instance 'v-box
 647      :parent dialog :border-width 10 :spacing 10
 648      :child (list
 649              (make-instance 'h-box
 650               :spacing 10
 651               :child (make-instance 'button
 652                       :label "Remove Selection"
 653                       :signal (list 'clicked
 654                                #'(lambda ()
 655                                    (let ((references
 656                                           (mapcar
 657                                            #'(lambda (path)
 658                                                (make-instance 'tree-row-reference :model store :path path))
 659                                            (tree-selection-get-selected-rows
 660                                             (tree-view-selection tree)))))
 661                                      (mapc
 662                                       #'(lambda (reference)
 663                                           (list-store-remove store reference))
 664                                       references))))))
 665              :expand nil)
 666      :child (list
 667              (make-instance 'h-box
 668               :spacing 10
 669               :child (make-instance 'check-button
 670                       :label "Show Headers" :active t
 671                       :signal (list 'toggled
 672                                #'(lambda (button)
 673                                    (setf
 674                                     (tree-view-headers-visible-p tree)
 675                                     (toggle-button-active-p button)))
 676                                :object t))
 677               :child (make-instance 'check-button
 678                       :label "Reorderable" :active nil
 679                       :signal (list 'toggled
 680                                #'(lambda (button)
 681                                    (setf
 682                                     (tree-view-reorderable-p tree)
 683                                     (toggle-button-active-p button)))
 684                                :object t))
 685               :child (list
 686                       (make-instance 'h-box
 687                        :child (make-instance 'label :label "Selection Mode: ")
 688                        :child (make-instance 'combo-box
 689                                :content '("Single" "Browse" "Multiple")
 690                                :active 0
 691                                :signal (list 'changed
 692                                         #'(lambda (combo-box)
 693                                             (setf
 694                                              (tree-selection-mode
 695                                               (tree-view-selection tree))
 696                                              (svref
 697                                               #(:single :browse :multiple)
 698                                               (combo-box-active combo-box))))
 699                                         :object t)))
 700                       :expand nil))
 701              :expand nil)
 702      :child (make-instance 'scrolled-window
 703             :child tree :hscrollbar-policy :automatic))))
 704
 705
 706 ;; Menus
 707
 708 (defun create-menu (depth tearoff)
 709   (unless (zerop depth)
 710     (let ((menu (make-instance 'menu)))
 711       (when tearoff
 712         (let ((menu-item (make-instance 'tearoff-menu-item)))
 713           (menu-shell-append menu menu-item)))
 714       (let ((group nil))
 715         (dotimes (i 5)
 716           (let ((menu-item
 717                  (make-instance 'radio-menu-item
 718                   :label (format nil "item ~2D - ~D" depth (1+ i)))))
 719             (if group
 720                 (add-to-radio-group menu-item group)
 721               (setq group menu-item))
 722             (unless (zerop (mod depth 2))
 723               (setf (check-menu-item-active-p menu-item) t))
 724             (menu-shell-append menu menu-item)
 725             (when (= i 3)
 726               (setf (widget-sensitive-p menu-item) nil))
 727             (let ((submenu (create-menu (1- depth) t)))
 728               (when submenu
 729                 (setf (menu-item-submenu menu-item) submenu))))))
 730       menu)))
 731
 732
 733 (define-simple-dialog create-menus (dialog "Menus" :default-width 200)
 734   (let* ((main (make-instance 'v-box :parent dialog))
 735 ;        (accel-group (make-instance 'accel-group))
 736          (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
 737 ;    (window-add-accel-group dialog accel-group)
 738
 739     (let ((menu-item (make-instance 'menu-item
 740                       :label (format nil "test~%line2"))))
 741       (setf (menu-item-submenu menu-item) (create-menu 2 t))
 742       (menu-shell-append menubar menu-item))
 743
 744     (let ((menu-item (make-instance 'menu-item :label "foo")))
 745       (setf (menu-item-submenu menu-item) (create-menu 3 t))
 746       (menu-shell-append menubar menu-item))
 747
 748     (let ((menu-item (make-instance 'menu-item :label "bar")))
 749       (setf (menu-item-submenu menu-item) (create-menu 4 t))
 750       (setf (menu-item-right-justified-p menu-item) t)
 751       (menu-shell-append menubar menu-item))
 752
 753     (make-instance 'v-box
 754      :spacing 10 :border-width 10 :parent main
 755      :child (make-instance 'combo-box
 756              :active 3
 757              :content (loop
 758                        for i from 1 to 5
 759                        collect (format nil "Item ~D" i))))
 760
 761     (widget-show-all main)))
 762
 763
 764 ;;; Notebook
 765
 766 (defun create-notebook-page (notebook page-num book-closed)
 767   (let* ((title (format nil "Page ~D" page-num))
 768          (page (make-instance 'frame :label title :border-width 10))
 769          (v-box (make-instance 'v-box
 770                  :homogeneous t :border-width 10 :parent page)))
 771
 772     (make-instance 'h-box
 773      :parent (list v-box :fill nil :padding 5) :homogeneous t
 774      :child-args '(:padding 5)
 775      :child (make-instance 'check-button
 776              :label "Fill Tab" :active t
 777              :signal (list 'toggled
 778                            #'(lambda (button)
 779                                (setf
 780                                 (notebook-child-tab-fill-p page)
 781                                 (toggle-button-active-p button)))
 782                            :object t))
 783      :child (make-instance 'check-button
 784              :label "Expand Tab"
 785              :signal (list 'toggled
 786                            #'(lambda (button)
 787                                (setf
 788                                 (notebook-child-tab-expand-p page)
 789                                 (toggle-button-active-p button)))
 790                            :object t))
 791      :child (make-instance 'check-button
 792              :label "Pack end"
 793              :signal (list 'toggled
 794                            #'(lambda (button)
 795                                (setf
 796                                 (notebook-child-tab-pack page)
 797                                 (if (toggle-button-active-p button)
 798                                     :end
 799                                   :start)))
 800                            :object t))
 801      :child (make-instance 'button
 802              :label "Hide page"
 803              :signal (list 'clicked #'(lambda () (widget-hide page)))))
 804
 805     (let ((label-box (make-instance 'h-box
 806                       :show-children t
 807                       :child-args '(:expand nil)
 808                       :child (make-instance 'image :pixbuf book-closed)
 809                       :child (make-instance 'label :label title)))
 810           (menu-box (make-instance 'h-box
 811                      :show-children t
 812                      :child-args '(:expand nil)
 813                      :child (make-instance 'image :pixbuf book-closed)
 814                      :child (make-instance 'label :label title))))
 815
 816       (widget-show-all page)
 817       (notebook-append notebook page label-box menu-box))))
 818
 819
 820 (define-simple-dialog create-notebook (dialog "Notebook")
 821   (let ((main (make-instance 'v-box :parent dialog)))
 822     (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
 823           (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
 824           (notebook (make-instance 'notebook
 825                      :border-width 10 :tab-pos :top :parent main)))
 826       (flet ((set-image (page func pixbuf)
 827                (setf
 828                 (image-pixbuf
 829                  (first (container-children (funcall func notebook page))))
 830                 pixbuf)))
 831         (signal-connect notebook 'switch-page
 832          #'(lambda (pointer page)
 833              (declare (ignore pointer))
 834              (set-image page #'notebook-menu-label book-open)
 835              (set-image page #'notebook-tab-label book-open)
 836              (when (slot-boundp notebook 'current-page)
 837                (let ((curpage (notebook-current-page notebook)))
 838                  (set-image curpage #'notebook-menu-label book-closed)
 839                  (set-image curpage #'notebook-tab-label book-closed))))))
 840       (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
 841
 842       (make-instance 'h-separator :parent (list main :expand nil :padding 10))
 843
 844       (make-instance 'h-box
 845        :spacing 5 :border-width 10
 846        :parent (list main :expand nil)
 847        :child-args '(:fill nil)
 848        :child (make-instance 'check-button
 849                :label "Popup menu"
 850                :signal (list 'clicked
 851                         #'(lambda (button)
 852                             (if (toggle-button-active-p button)
 853                                 (notebook-popup-enable notebook)
 854                                 (notebook-popup-disable notebook)))
 855                         :object t))
 856        :child (make-instance 'check-button
 857                :label "Homogeneous tabs"
 858                :signal (list 'clicked
 859                         #'(lambda (button)
 860                             (setf
 861                              (notebook-homogeneous-p notebook)
 862                              (toggle-button-active-p button)))
 863                         :object t)))
 864
 865       (make-instance 'h-box
 866        :spacing 5 :border-width 10
 867        :parent (list main :expand nil)
 868        :child-args '(:expand nil)
 869        :child (make-instance 'label :label "Notebook Style: ")
 870        :child (let ((scrollable-p nil))
 871                 (make-instance 'combo-box
 872                  :content '("Standard" "No tabs" "Scrollable") :active 0
 873                  :signal (list 'changed
 874                           #'(lambda (combo-box)
 875                               (case (combo-box-active combo-box)
 876                                 (0
 877                                  (setf (notebook-show-tabs-p notebook) t)
 878                                  (when scrollable-p
 879                                    (setq scrollable-p nil)
 880                                    (setf (notebook-scrollable-p notebook) nil)
 881                                    (loop repeat 10
 882                                     do (notebook-remove-page notebook 5))))
 883                                 (1
 884                                  (setf (notebook-show-tabs-p notebook) nil)
 885                                  (when scrollable-p
 886                                    (setq scrollable-p nil)
 887                                    (setf (notebook-scrollable-p notebook) nil)
 888                                    (loop repeat 10
 889                                      do (notebook-remove-page notebook 5))))
 890                                 (2
 891                                  (unless scrollable-p
 892                                    (setq scrollable-p t)
 893                                    (setf (notebook-show-tabs-p notebook) t)
 894                                    (setf (notebook-scrollable-p notebook) t)
 895                                    (loop for i from 6 to 15
 896                                     do (create-notebook-page notebook i book-closed))))))
 897                           :object t)))
 898        :child (make-instance 'button
 899                :label "Show all Pages"
 900                :signal (list 'clicked
 901                         #'(lambda ()
 902                             (map-container nil #'widget-show notebook)))))
 903
 904       (make-instance 'h-box
 905        :spacing 5 :border-width 10
 906        :parent (list main :expand nil)
 907        :child (make-instance 'button
 908                :label "prev"
 909                :signal (list 'clicked #'notebook-prev-page :object notebook))
 910        :child (make-instance 'button
 911                :label "next"
 912                :signal (list 'clicked #'notebook-next-page :object notebook))
 913        :child (make-instance 'button
 914                :label "rotate"
 915                :signal (let ((tab-pos 0))
 916                          (list 'clicked
 917                           #'(lambda ()
 918                               (setq tab-pos (mod (1+ tab-pos) 4))
 919                               (setf
 920                                (notebook-tab-pos notebook)
 921                                (svref #(:top :right :bottom :left) tab-pos))))))))
 922     (widget-show-all main)))
 923
 924
 925 ;;; Panes
 926
 927 (defun toggle-resize (child)
 928   (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
 929
 930 (defun toggle-shrink (child)
 931   (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
 932
 933 (defun create-pane-options (paned frame-label label1 label2)
 934   (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
 935     (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
 936     (let ((check-button (make-instance 'check-button :label "Resize")))
 937       (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
 938       (signal-connect check-button 'toggled
 939        #'toggle-resize :object (paned-child1 paned)))
 940     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
 941       (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
 942       (signal-connect check-button 'toggled
 943        #'toggle-shrink :object (paned-child1 paned)))
 944
 945     (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
 946     (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
 947       (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
 948       (signal-connect check-button 'toggled
 949        #'toggle-resize :object (paned-child2 paned)))
 950     (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
 951       (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
 952       (signal-connect check-button 'toggled
 953        #'toggle-shrink :object (paned-child2 paned)))
 954     (make-instance 'frame :label frame-label :border-width 4 :child table)))
 955
 956 (define-toplevel create-panes (window "Panes")
 957   (let* ((hpaned (make-instance 'h-paned
 958                   :child1 (make-instance 'frame
 959                            :width-request 60 :height-request 60
 960                            :shadow-type :in
 961                            :child (make-instance 'button :label "Hi there"))
 962                   :child2 (make-instance 'frame
 963                            :width-request 80 :height-request 60
 964                            :shadow-type :in)))
 965          (vpaned (make-instance 'v-paned
 966                   :border-width 5
 967                   :child1 hpaned
 968                   :child2 (make-instance 'frame
 969                            :width-request 80 :height-request 60
 970                            :shadow-type :in))))
 971
 972     (make-instance 'v-box
 973      :parent window
 974      :child-args '(:expand nil)
 975      :child (list vpaned :expand t)
 976      :child (create-pane-options hpaned "Horizontal" "Left" "Right")
 977      :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
 978
 979
 980 ;;; Progress bar
 981
 982 (define-simple-dialog create-progress-bar (dialog "Progress Bar")
 983   (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
 984          (activity-mode-button (make-instance 'check-button
 985                                 :label "Activity mode"))
 986          (timer (timeout-add 100
 987                  #'(lambda ()
 988                      (if (toggle-button-active-p activity-mode-button)
 989                          (progress-bar-pulse progress)
 990                        (let ((fract (+ (progress-bar-fraction progress) 0.01)))
 991                          (setf
 992                           (progress-bar-fraction progress)
 993                           (if (> fract 1.0)
 994                               0.0
 995                             fract))))
 996                      t))))
 997
 998     (make-instance 'v-box
 999      :parent dialog :border-width 10 :spacing 10
1000      :child progress
1001      :child activity-mode-button)
1002
1003     (signal-connect dialog 'destroy
1004      #'(lambda () (when timer (timeout-remove timer))))))
1005
1006
1007 ;;; Radio buttons
1008
1009 (define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1010   (make-instance 'v-box
1011    :parent dialog :border-width 10 :spacing 10
1012    :children (make-radio-group 'radio-button
1013               '((:label "button1") (:label "button2") (:label "button3"))
1014               nil)))
1015
1016
1017 ;;; Rangle controls
1018
1019 (define-simple-dialog create-range-controls (dialog "Range controls")
1020   (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
1021     (make-instance 'v-box
1022      :parent dialog :border-width 10 :spacing 10
1023      :child (make-instance 'h-scale
1024              :width-request 150 :adjustment adjustment :inverted t
1025              :update-policy :delayed :digits 1 :draw-value t)
1026      :child (make-instance 'h-scrollbar
1027              :adjustment adjustment :update-policy :continuous))))
1028
1029
1030 ;;; Reparent test
1031
1032 (define-simple-dialog create-reparent (dialog "Reparent")
1033   (let ((main (make-instance 'h-box
1034                :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1035         (label (make-instance 'label :label "Hello World")))
1036
1037     (flet ((create-frame (title)
1038              (let* ((frame (make-instance 'frame :label title :parent main))
1039                     (box (make-instance 'v-box
1040                           :spacing 5 :border-width 5 :parent frame))
1041                     (button (make-instance 'button
1042                              :label "switch" :parent (list box :expand nil))))
1043                (signal-connect button 'clicked
1044                 #'(lambda ()
1045                     (widget-reparent label box)))
1046                box)))
1047
1048       (box-pack-start (create-frame "Frame 1") label nil t 0)
1049       (create-frame "Frame 2"))
1050     (widget-show-all main)))
1051
1052
1053 ;;; Rulers
1054
1055 (define-toplevel create-rulers (window "Rulers"
1056                                 :default-width 300 :default-height 300
1057                                 :events '(:pointer-motion :pointer-motion-hint))
1058   (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1059         (h-ruler (make-instance 'h-ruler
1060                   :metric :centimeters :lower 100.0d0 :upper 0.0d0
1061                   :position 0.0d0 :max-size 20.0d0))
1062         (v-ruler (make-instance 'v-ruler
1063                   :lower 5.0d0 :upper 15.0d0
1064                   :position 0.0d0 :max-size 20.0d0)))
1065     (signal-connect window 'motion-notify-event
1066      #'(lambda (event)
1067          (widget-event h-ruler event)
1068          (widget-event v-ruler event)))
1069     (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1070     (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
1071
1072
1073 ;;; Scrolled window
1074
1075 (define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1076                                                       :default-width 300
1077                                                       :default-height 300)
1078   (let* ((scrolled-window
1079           (make-instance 'scrolled-window
1080            :parent dialog :border-width 10
1081            :vscrollbar-policy :automatic
1082            :hscrollbar-policy :automatic))
1083          (table
1084           (make-instance 'table
1085            :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
1086            :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1087            :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
1088
1089       (scrolled-window-add-with-viewport scrolled-window table)
1090       (dotimes (i 20)
1091         (dotimes (j 20)
1092           (let ((button
1093                  (make-instance 'toggle-button
1094                   :label (format nil "button (~D,~D)~%" i j))))
1095             (table-attach table button i (1+ i) j (1+ j)))))
1096       (widget-show-all scrolled-window)))
1097
1098
1099 ;;; Size group
1100
1101 (define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1102   (let ((size-group (make-instance 'size-group)))
1103     (flet ((create-frame (label rows)
1104              (let ((table (make-instance 'table
1105                            :n-rows (length rows) :n-columns 2 :homogeneous nil
1106                            :row-spacing 5 :column-spacing 10 :border-width 5)))
1107                (loop
1108                 for row in rows
1109                 for i from 0
1110                 do (table-attach table
1111                     (create-label (first row) :xalign 0 :yalign 1)
1112                     0 1 i (1+ i) :x-options '(:expand :fill))
1113                    (let ((combo (make-instance 'combo-box
1114                                  :content (rest row) :active 0)))
1115                      (size-group-add-widget size-group combo)
1116                      (table-attach table combo 1 2 i (1+ i))))
1117                (make-instance 'frame :label label :child table))))
1118
1119       (make-instance 'v-box
1120        :parent dialog :border-width 5 :spacing 5
1121        :child (create-frame "Color Options"
1122                '(("Foreground" "Red" "Green" "Blue")
1123                  ("Background" "Red" "Green" "Blue")))
1124        :child (create-frame "Line Options"
1125                '(("Dashing" "Solid" "Dashed" "Dotted")
1126                  ("Line ends" "Square" "Round" "Arrow")))
1127        :child (create-check-button "Enable grouping"
1128                #'(lambda (active)
1129                    (setf
1130                     (size-group-mode size-group)
1131                     (if active :horizontal :none)))
1132                t)))))
1133
1134
1135 ;;; Shapes
1136
1137 (defun create-shape-icon (xpm-file x y px py type root-window destroy)
1138   (let ((window
1139          (make-instance 'window
1140           :type type :default-width 100 :default-height 100
1141           :events '(:button-motion :pointer-motion-hint :button-press)
1142           :signal (list 'destroy destroy))))
1143
1144     (widget-realize window)
1145     (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1146       (let ((fixed (make-instance 'fixed :parent window)))
1147         (fixed-put fixed (create-image-widget source mask) px py))
1148       (widget-shape-combine-mask window mask px py))
1149
1150     (let ((x-offset 0)
1151           (y-offset 0))
1152       (declare (fixnum x-offset y-offset))
1153       (signal-connect window 'button-press-event
1154        #'(lambda (event)
1155            (when (typep event 'gdk:button-press-event)
1156              (setq x-offset (truncate (gdk:event-x event)))
1157              (setq y-offset (truncate (gdk:event-y event)))
1158              (grab-add window)
1159              (gdk:pointer-grab (widget-window window)
1160               :events '(:button-release :button-motion :pointer-motion-hint)
1161               :owner-events t :time event))))
1162
1163       (signal-connect window 'button-release-event
1164        #'(lambda (event)
1165            (grab-remove window)
1166            (gdk:pointer-ungrab event)))
1167
1168       (signal-connect window 'motion-notify-event
1169        #'(lambda (event)
1170            (declare (ignore event))
1171            (multiple-value-bind (win xp yp mask)
1172                (gdk:window-get-pointer root-window)
1173              (declare (ignore mask win) (fixnum xp yp))
1174              (window-move window (- xp x-offset) (- yp y-offset))))))
1175
1176     (window-move window x y)
1177     (widget-show-all window)
1178     window))
1179
1180
1181 (let ((modeller nil)
1182       (sheets nil)
1183       (rings nil))
1184   (defun create-shapes ()
1185     (let ((root-window (gdk:get-root-window)))
1186       (if (not modeller)
1187           (setq
1188            modeller
1189            (create-shape-icon
1190             "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1191             #'(lambda () (setq modeller nil))))
1192         (widget-destroy modeller))
1193
1194       (if (not sheets)
1195           (setq
1196            sheets
1197            (create-shape-icon
1198             "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1199             #'(lambda () (setq sheets nil))))
1200         (widget-destroy sheets))
1201
1202       (if (not rings)
1203           (setq
1204            rings
1205            (create-shape-icon
1206             "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1207             #'(lambda () (setq rings nil))))
1208         (widget-destroy rings)))))
1209
1210
1211
1212 ;;; Spin buttons
1213
1214 (define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1215   (let ((main (make-instance 'v-box
1216                :spacing 5 :border-width 10 :parent dialog)))
1217
1218     (flet ((create-date-spinner (label adjustment shadow-type)
1219              (declare (ignore shadow-type))
1220              (make-instance 'v-box
1221               :child-args '(:expand nil)
1222               :child (make-instance 'label
1223                       :label label :xalign 0.0 :yalign 0.5)
1224               :child (make-instance 'spin-button
1225                       :adjustment adjustment :wrap t))))
1226       (multiple-value-bind (sec min hour date month year day daylight-p zone)
1227           (get-decoded-time)
1228         (declare (ignore sec min hour day daylight-p zone))
1229         (make-instance 'frame
1230          :label "Not accelerated" :parent main
1231          :child (make-instance 'h-box
1232                  :border-width 10
1233                  :child-args '(:padding 5)
1234                  :child (create-date-spinner "Day : "
1235                          (adjustment-new date 1 31 1 5 0) :out)
1236                  :child (create-date-spinner "Month : "
1237                          (adjustment-new month 1 12 1 5 0) :etched-in)
1238                  :child (create-date-spinner "Year : "
1239                          (adjustment-new year 0 2100 1 100 0) :in)))))
1240
1241     (let ((spinner1 (make-instance 'spin-button
1242                      :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1243                       :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1244           (spinner2 (make-instance 'spin-button
1245                      :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1246                      :climb-rate 1.0 :wrap t))
1247           (value-label (make-instance 'label :label "0")))
1248       (signal-connect (spin-button-adjustment spinner2) 'value-changed
1249        #'(lambda ()
1250            (setf
1251             (spin-button-digits spinner1)
1252             (floor (spin-button-value spinner2)))))
1253
1254       (make-instance 'frame
1255        :label "Accelerated" :parent main
1256        :child (make-instance 'v-box
1257                :border-width 5
1258                :child (list
1259                        (make-instance 'h-box
1260                         :child-args '(:padding 5)
1261                         :child (make-instance 'v-box
1262                                 :child (make-instance 'label
1263                                         :label "Value :"
1264                                         :xalign 0.0 :yalign 0.5)
1265                                 :child spinner1)
1266                         :child (make-instance 'v-box
1267                                 :child (make-instance 'label
1268                                         :label "Digits :"
1269                                         :xalign 0.0 :yalign 0.5)
1270                                 :child spinner2))
1271                        :expand nil :padding 5)
1272                :child (make-instance 'check-button
1273                        :label "Snap to 0.5-ticks" :active t
1274                        :signal (list 'clicked
1275                                 #'(lambda (button)
1276                                     (setf
1277                                      (spin-button-snap-to-ticks-p spinner1)
1278                                      (toggle-button-active-p button)))
1279                                 :object t))
1280                :child (make-instance 'check-button
1281                        :label "Numeric only input mode" :active t
1282                        :signal (list 'clicked
1283                                 #'(lambda (button)
1284                                     (setf
1285                                      (spin-button-numeric-p spinner1)
1286                                      (toggle-button-active-p button)))
1287                                 :object t))
1288                :child value-label
1289                :child (list
1290                        (make-instance 'h-box
1291                         :child-args '(:padding 5)
1292                         :child (make-instance 'button
1293                                 :label "Value as Int"
1294                                 :signal (list 'clicked
1295                                          #'(lambda ()
1296                                              (setf
1297                                               (label-label value-label)
1298                                               (format nil "~D"
1299                                                (spin-button-value-as-int
1300                                                 spinner1))))))
1301                         :child (make-instance 'button
1302                                 :label "Value as Float"
1303                                 :signal (list 'clicked
1304                                          #'(lambda ()
1305                                              (setf
1306                                               (label-label value-label)
1307                                               (format nil
1308                                                (format nil "~~,~DF"
1309                                                 (spin-button-digits spinner1))
1310                                                (spin-button-value spinner1)))))))
1311                        :padding 5 :expand nil))))
1312     (widget-show-all main)))
1313
1314
1315 ;;; Statusbar
1316
1317 (define-toplevel create-statusbar (window "Statusbar")
1318   (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1319         (close-button (create-button '("close" :can-default t)
1320                        #'widget-destroy :object window))
1321         (counter 0))
1322
1323     (signal-connect statusbar 'text-popped
1324      #'(lambda (context-id text)
1325          (declare (ignore context-id))
1326          (format nil "Popped: ~A~%" text)))
1327
1328     (make-instance 'v-box
1329      :parent window
1330      :child (make-instance 'v-box
1331              :border-width 10 :spacing 10
1332              :child (create-button "push something"
1333                      #'(lambda ()
1334                          (statusbar-push statusbar 1
1335                           (format nil "something ~D" (incf counter)))))
1336              :child (create-button "pop"
1337                      #'(lambda ()
1338                          (statusbar-pop statusbar 1)))
1339              :child (create-button "steal #4"
1340                      #'(lambda ()
1341                          (statusbar-remove statusbar 1 4)))
1342              :child (create-button "dump stack")
1343              :child (create-button "test contexts"))
1344      :child (list (make-instance 'h-separator) :expand nil)
1345      :child (list
1346              (make-instance 'v-box :border-width 10 :child close-button)
1347              :expand nil)
1348      :child (list statusbar :expand nil))
1349
1350     (widget-grab-focus close-button)))
1351
1352
1353 ;;; Idle test
1354
1355 (define-simple-dialog create-idle-test (dialog "Idle Test")
1356   (let ((label (make-instance 'label
1357                 :label "count: 0" :xpad 10 :ypad 10))
1358         (idle nil)
1359         (count 0))
1360     (signal-connect dialog 'destroy
1361      #'(lambda () (when idle (idle-remove idle))))
1362
1363     (make-instance 'v-box
1364      :parent dialog :border-width 10 :spacing 10
1365      :child label
1366      :child (make-instance 'frame
1367              :label "Label Container" :border-width 5
1368              :child(make-instance 'v-box
1369                    :children (make-radio-group 'radio-button
1370                               '((:label "Resize-Parent" :value :parent :active t)
1371                                 (:label "Resize-Queue" :value :queue)
1372                                 (:label "Resize-Immediate" :value :immediate))
1373                               #'(lambda (mode)
1374                                   (setf
1375                                    (container-resize-mode (dialog-action-area dialog)) mode))))))
1376
1377     (dialog-add-button dialog "Start"
1378      #'(lambda ()
1379          (unless idle
1380            (setq idle
1381             (idle-add
1382              #'(lambda ()
1383                  (incf count)
1384                  (setf (label-label label) (format nil "count: ~D" count))
1385                  t))))))
1386
1387     (dialog-add-button dialog "Stop"
1388      #'(lambda ()
1389          (when idle
1390            (idle-remove idle)
1391            (setq idle nil))))))
1392
1393
1394
1395 ;;; Timeout test
1396
1397 (define-simple-dialog create-timeout-test (dialog "Timeout Test")
1398   (let ((label (make-instance 'label
1399                 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1400         (timer nil)
1401         (count 0))
1402     (signal-connect dialog 'destroy
1403      #'(lambda () (when timer (timeout-remove timer))))
1404
1405     (dialog-add-button dialog "Start"
1406      #'(lambda ()
1407          (unless timer
1408            (setq timer
1409             (timeout-add 100
1410              #'(lambda ()
1411                  (incf count)
1412                  (setf (label-label label) (format nil "count: ~D" count))
1413                  t))))))
1414
1415     (dialog-add-button dialog "Stop"
1416      #'(lambda ()
1417          (when timer
1418            (timeout-remove timer)
1419            (setq timer nil))))))
1420
1421
1422 ;;; Text
1423
1424 (define-simple-dialog create-text (dialog "Text" :default-width 400
1425                                                  :default-height 400)
1426   (let* ((text-view (make-instance 'text-view
1427                      :border-width 10 :visible t :wrap-mode :word))
1428          (buffer (text-view-buffer text-view))
1429          (active-tags ()))
1430
1431     (text-buffer-create-tag buffer "Bold" :weight :bold)
1432     (text-buffer-create-tag buffer "Italic" :style :italic)
1433     (text-buffer-create-tag buffer "Underline" :underline :single)
1434
1435     (flet ((create-toggle-callback (tag-name)
1436              (let ((tag (text-tag-table-lookup
1437                          (text-buffer-tag-table buffer) tag-name)))
1438                #'(lambda (active)
1439                    (unless (eq (and (find tag active-tags) t) active)
1440                      ;; user activated
1441                      (if active
1442                          (push tag active-tags)
1443                        (setq active-tags (delete tag active-tags)))
1444                      (multiple-value-bind (non-zero-p start end)
1445                          (text-buffer-get-selection-bounds buffer)
1446                        (declare (ignore non-zero-p))
1447                        (if active
1448                            (text-buffer-apply-tag buffer tag start end)
1449                          (text-buffer-remove-tag buffer tag start end))))))))
1450
1451       (let* ((actions
1452               (make-instance 'action-group
1453                :action (create-toggle-action
1454                         "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1455                         (create-toggle-callback "Bold"))
1456                :action (create-toggle-action
1457                         "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1458                         (create-toggle-callback "Italic"))
1459                :action (create-toggle-action
1460                         "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1461                         (create-toggle-callback "Underline"))))
1462              (ui (make-instance 'ui-manager)))
1463
1464         (ui-manager-insert-action-group ui actions)
1465         (ui-manager-add-ui ui
1466          '((:toolbar "ToolBar"
1467             (:toolitem "Bold")
1468             (:toolitem "Italic")
1469             (:toolitem "Underline"))))
1470
1471         ;; Callback to activate/deactivate toolbar buttons when cursor
1472         ;; is moved
1473         (signal-connect buffer 'mark-set
1474          #'(lambda (location mark)
1475              (declare (ignore mark))
1476              (text-tag-table-foreach (text-buffer-tag-table buffer)
1477               #'(lambda (tag)
1478                   (let ((active
1479                          (or
1480                           (and
1481                            (text-iter-has-tag-p location tag)
1482                            (not (text-iter-begins-tag-p location tag)))
1483                           (text-iter-ends-tag-p location tag))))
1484                     (unless (eq active (and (find tag active-tags) t))
1485                       (if active
1486                           (push tag active-tags)
1487                         (setq active-tags (delete tag active-tags)))
1488                       (setf
1489                        (toggle-action-active-p
1490                         (action-group-get-action actions (text-tag-name tag)))
1491                        active)))))))
1492
1493         ;; Callback to apply active tags when a character is inserted
1494         (signal-connect buffer 'insert-text
1495          #'(lambda (iter &rest args)
1496              (declare (ignore args))
1497              (let ((before (text-buffer-get-iter-at-offset buffer
1498                             (1- (text-iter-offset iter)))))
1499                (loop
1500                 for tag in active-tags
1501                 do (text-buffer-apply-tag buffer tag before iter))))
1502          :after t)
1503
1504         (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1505         (container-add dialog text-view)))))
1506
1507
1508 ;;; Toggle buttons
1509
1510 (define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1511   (make-instance 'v-box
1512    :border-width 10 :spacing 10 :parent dialog
1513       :children (loop
1514               for n from 1 to 3
1515               collect (make-instance 'toggle-button
1516                        :label (format nil "Button~D" (1+ n))))))
1517
1518
1519
1520 ;;; Toolbar test
1521
1522 (defun create-toolbar (window)
1523   (make-instance 'toolbar
1524    :show-tooltips t :show-arrow nil
1525
1526    ;; Insert a stock item
1527    :child (make-instance 'tool-button
1528            :stock  "gtk-quit"
1529            :tip-text "Destroy toolbar"
1530            :tip-private "Toolbar/Quit"
1531            :signal (list 'clicked #'(lambda () (widget-destroy window))))
1532
1533    :child (make-instance 'separator-tool-item)
1534
1535    :child (make-instance 'tool-button
1536            :label "Horizontal" :stock "gtk-go-forward"
1537            :tip-text "Horizontal toolbar layout"
1538            :tip-private "Toolbar/Horizontal"
1539            :signal (list 'clicked
1540                     #'(lambda (toolbar)
1541                         (setf (toolbar-orientation toolbar) :horizontal))
1542                     :object :parent))
1543
1544    :child (make-instance 'tool-button
1545            :label "Vertical" :stock "gtk-go-down"
1546            :tip-text "Vertical toolbar layout"
1547            :tip-private "Toolbar/Vertical"
1548            :signal (list 'clicked
1549                     #'(lambda (toolbar)
1550                         (setf (toolbar-orientation toolbar) :vertical))
1551                     :object :parent))
1552
1553    :child (make-instance 'separator-tool-item)
1554
1555    :children (make-radio-group 'radio-tool-button
1556               '((:label "Icons" :stock "gtk-justify-left"
1557                  :tip-text "Only show toolbar icons"
1558                  :tip-private "Toolbar/IconsOnly"
1559                  :value :icons)
1560                 (:label "Both" :stock "gtk-justify-center"
1561                  :tip-text "Show toolbar icons and text"
1562                  :tip-private "Toolbar/Both"
1563                  :value :both :active t)
1564                 (:label "Text" :stock "gtk-justify-right"
1565                  :tip-text "Show toolbar text"
1566                  :tip-private "Toolbar/TextOnly"
1567                  :value :text))
1568               (list
1569                #'(lambda (toolbar style)
1570                    (setf (toolbar-style toolbar) style))
1571                :object :parent))
1572
1573    :child (make-instance 'separator-tool-item)
1574
1575    :child (make-instance 'tool-item
1576            :child (make-instance 'entry)
1577            :tip-text "This is an unusable GtkEntry"
1578            :tip-private "Hey don't click me!")
1579
1580    :child (make-instance 'separator-tool-item)
1581
1582    :child (make-instance 'tool-button
1583            :label "Enable" :stock "gtk-add"
1584            :tip-text "Enable tooltips"
1585            :tip-private "Toolbar/EnableTooltips"
1586            :signal (list 'clicked
1587                     #'(lambda (toolbar)
1588                         (setf (toolbar-show-tooltips-p toolbar) t))
1589                     :object :parent))
1590
1591    :child (make-instance 'tool-button
1592            :label "Disable" :stock "gtk-remove"
1593            :tip-text "Disable tooltips"
1594            :tip-private "Toolbar/DisableTooltips"
1595            :signal (list 'clicked
1596                     #'(lambda (toolbar)
1597                         (setf (toolbar-show-tooltips-p toolbar) nil))
1598                     :object :parent))
1599
1600 ;;    :child (make-instance 'separator-tool-item)
1601
1602 ;;    :child (make-instance 'tool-button
1603 ;;         :label "GTK" :icon #p"clg:examples;gtk.png"
1604 ;;         :tip-text "GTK+ Logo"
1605 ;;         :tip-private "Toolbar/GTK+")
1606    ))
1607
1608 (define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1609   (container-add window (create-toolbar window)))
1610
1611
1612
1613 ;;; Tooltips test
1614
1615 (define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1616   (let ((tooltips (make-instance 'tooltips)))
1617     (flet ((create-button (label tip-text tip-private)
1618              (let ((button (make-instance 'toggle-button :label label)))
1619                (tooltips-set-tip tooltips button tip-text tip-private)
1620                button)))
1621       (make-instance 'v-box
1622        :parent dialog :border-width 10 :spacing 10
1623        :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
1624        :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")))))
1625
1626
1627 ;;; UI Manager
1628
1629 (defvar *ui-description*
1630   '((:menubar "MenuBar"
1631      (:menu "FileMenu"
1632       (:menuitem "New")
1633       (:menuitem "Open")
1634       (:menuitem "Save")
1635       (:menuitem "SaveAs")
1636       :separator
1637       (:menuitem "Quit"))
1638      (:menu "PreferencesMenu"
1639        (:menu "ColorMenu"
1640         (:menuitem "Red")
1641         (:menuitem "Green")
1642         (:menuitem "Blue"))
1643        (:menu "ShapeMenu"
1644         (:menuitem "Square")
1645         (:menuitem "Rectangle")
1646         (:menuitem "Oval"))
1647        (:menuitem "Bold"))
1648      (:menu "HelpMenu"
1649       (:menuitem "About")))
1650     (:toolbar "ToolBar"
1651      (:toolitem "Open")
1652      (:toolitem "Quit")
1653      (:separator "Sep1")
1654      (:toolitem "Logo"))))
1655
1656 (define-toplevel create-ui-manager (window "UI Manager")
1657   (let ((actions
1658          (make-instance 'action-group
1659           :name "Actions"
1660           :action (create-action "FileMenu" nil "_File")
1661           :action (create-action "PreferencesMenu" nil "_Preferences")
1662           :action (create-action "ColorMenu" nil "_Color")
1663           :action (create-action "ShapeMenu" nil "_Shape")
1664           :action (create-action "HelpMenu" nil "_Help")
1665           :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1666           :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
1667           :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1668           :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1669           :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
1670           :action (create-action "About" nil "_About" "<control>A" "About")
1671           :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1672           :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1673           :actions (create-radio-actions
1674                     '(("Red" nil "_Red" "<control>R" "Blood")
1675                       ("Green" nil "_Green" "<control>G" "Grass")
1676                       ("Blue" nil "_Blue" "<control>B" "Sky"))
1677                     "Green")
1678           :actions (create-radio-actions
1679                     '(("Square" nil "_Square" "<control>S" "Square")
1680                       ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1681                       ("Oval" nil "_Oval" "<control>O" "Egg")))))
1682         (ui (make-instance 'ui-manager)))
1683
1684     (ui-manager-insert-action-group ui actions)
1685     (ui-manager-add-ui ui *ui-description*)
1686
1687     (window-add-accel-group window (ui-manager-accel-group ui))
1688
1689     (make-instance 'v-box
1690      :parent window
1691      :child (list
1692              (ui-manager-get-widget ui "/MenuBar")
1693              :expand nil :fill nil)
1694      :child (list
1695              (ui-manager-get-widget ui "/ToolBar")
1696              :expand nil :fill nil)
1697      :child (make-instance 'label
1698              :label "Type <alt> to start"
1699              :xalign 0.5 :yalign 0.5
1700              :width-request 200 :height-request 200))))
1701
1702
1703
1704 ;;; Main window
1705
1706 (defun create-main-window ()
1707 ;;   (rc-parse "clg:examples;testgtkrc2")
1708 ;;   (rc-parse "clg:examples;testgtkrc")
1709
1710   (let* ((button-specs
1711           '(("button box" create-button-box)
1712             ("buttons" create-buttons)
1713             ("calendar" create-calendar)
1714             ("check buttons" create-check-buttons)
1715             ("color selection" create-color-selection)
1716             ("cursors" create-cursors)
1717             ("dialog" create-dialog)
1718 ;; ;        ("dnd")
1719             ("entry" create-entry)
1720 ;;          ("event watcher")
1721             ("enxpander" create-expander)
1722             ("file chooser" create-file-chooser)
1723             ("font selection" create-font-selection)
1724             ("handle box" create-handle-box)
1725             ("image" create-image)
1726             ("labels" create-labels)
1727             ("layout" create-layout)
1728             ("list" create-list)
1729             ("menus" create-menus)
1730 ;;          ("modal window")
1731             ("notebook" create-notebook)
1732             ("panes" create-panes)
1733             ("progress bar" create-progress-bar)
1734             ("radio buttons" create-radio-buttons)
1735             ("range controls" create-range-controls)
1736 ;;          ("rc file")
1737             ("reparent" create-reparent)
1738             ("rulers" create-rulers)
1739 ;;          ("saved position")
1740             ("scrolled windows" create-scrolled-windows)
1741             ("size group" create-size-group)
1742             ("shapes" create-shapes)
1743             ("spinbutton" create-spins)
1744             ("statusbar" create-statusbar)
1745             ("test idle" create-idle-test)
1746 ;;          ("test mainloop")
1747 ;;          ("test scrolling")
1748 ;;          ("test selection")
1749             ("test timeout" create-timeout-test)
1750             ("text" create-text)
1751             ("toggle buttons" create-toggle-buttons)
1752             ("toolbar" create-toolbar-window)
1753             ("tooltips" create-tooltips)
1754 ;;          ("tree" #|create-tree|#)
1755             ("UI manager" create-ui-manager)
1756 ))
1757         (main-window (make-instance 'window
1758                       :title "testgtk.lisp" :name "main_window"
1759                       :default-width 200 :default-height 400
1760                       :allow-grow t :allow-shrink nil))
1761         (scrolled-window (make-instance 'scrolled-window
1762                           :hscrollbar-policy :automatic
1763                           :vscrollbar-policy :automatic
1764                           :border-width 10))
1765         (close-button (make-instance 'button
1766                        :label "close" :can-default t
1767                        :signal (list 'clicked #'widget-destroy
1768                                      :object main-window))))
1769
1770     (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1771       (setf
1772        (window-icon main-window)
1773        (gdk:pixbuf-add-alpha icon t 254 254 252)))
1774
1775     ;; Main box
1776     (make-instance 'v-box
1777      :parent main-window
1778      :child-args '(:expand nil)
1779      :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1780      :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1781      :child (list (make-instance 'label
1782                    :label #-cmu(format nil "~A (~A)"
1783                                 (lisp-implementation-type)
1784                                 (lisp-implementation-version))
1785                           ;; The version string in CMUCL is far too long
1786                           #+cmu(lisp-implementation-type))
1787                   :fill nil)
1788      :child (list scrolled-window :expand t)
1789      :child (make-instance 'h-separator)
1790      :child (make-instance 'v-box
1791              :homogeneous nil :spacing 10 :border-width 10
1792              :child close-button))
1793
1794     (let ((content-box
1795            (make-instance 'v-box
1796             :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1797             :children (mapcar #'(lambda (spec)
1798                                   (apply #'create-button spec))
1799                               button-specs))))
1800       (scrolled-window-add-with-viewport scrolled-window content-box))
1801
1802     (widget-grab-focus close-button)
1803     (widget-show-all main-window)
1804     main-window))
1805
1806 (clg-init)
1807 (create-main-window)