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