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