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