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