chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Made timeout and idle functional
[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
36c95ad8 18;; $Id: testgtk.lisp,v 1.9 2004/12/05 00:06:41 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)
36c95ad8 58 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)
35ec512c 59 ,@body))
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
35ec512c 1438;; (define-standard-dialog create-idle-test "Idle Test"
1439;; (let* ((container (make-instance 'hbox :parent main-box))
1440;; (label (make-instance 'label
1441;; :label "count: 0" :xpad 10 :ypad 10 :parent container))
1442;; (idle nil)
1443;; (count 0))
1444;; (declare (fixnum count))
1445;; (signal-connect
1446;; window 'destroy #'(lambda () (when idle (idle-remove idle))))
0d07716f 1447
35ec512c 1448;; (make-instance 'frame
1449;; :label "Label Container" :border-width 5 :parent main-box
1450;; :child
1451;; (make-instance 'v-box
1452;; :children
1453;; (create-radio-button-group
1454;; '(("Resize-Parent" :parent)
1455;; ("Resize-Queue" :queue)
1456;; ("Resize-Immediate" :immediate))
1457;; 0
1458;; '(setf container-resize-mode) container)))
1459
1460;; (make-instance 'button
1461;; :label "start" :can-default t :parent action-area
1462;; :signals
1463;; (list
1464;; (list
1465;; 'clicked
1466;; #'(lambda ()
1467;; (unless idle
1468;; (setq
1469;; idle
1470;; (idle-add
1471;; #'(lambda ()
1472;; (incf count)
1473;; (setf (label-label label) (format nil "count: ~D" count))
1474;; t))))))))
0d07716f 1475
35ec512c 1476;; (make-instance 'button
1477;; :label "stop" :can-default t :parent action-area
1478;; :signals
1479;; (list
1480;; (list
1481;; 'clicked
1482;; #'(lambda ()
1483;; (when idle
1484;; (idle-remove idle)
1485;; (setq idle nil))))))))
0d07716f 1486
1487
1488
1489;;; Timeout test
1490
35ec512c 1491;; (define-standard-dialog create-timeout-test "Timeout Test"
1492;; (let ((label (make-instance 'label
1493;; :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
1494;; (timer nil)
1495;; (count 0))
1496;; (declare (fixnum count))
1497;; (signal-connect
1498;; window 'destroy #'(lambda () (when timer (timeout-remove timer))))
4fb50b71 1499
35ec512c 1500;; (make-instance 'button
1501;; :label "start" :can-default t :parent action-area
1502;; :signals
1503;; (list
1504;; (list
1505;; 'clicked
1506;; #'(lambda ()
1507;; (unless timer
1508;; (setq
1509;; timer
1510;; (timeout-add
1511;; 100
1512;; #'(lambda ()
1513;; (incf count)
1514;; (setf (label-label label) (format nil "count: ~D" count))
1515;; t))))))))
1516
1517;; (make-instance 'button
1518;; :label "stop" :can-default t :parent action-area
1519;; :signals
1520;; (list
1521;; (list
1522;; 'clicked
1523;; #'(lambda ()
1524;; (when timer
1525;; (timeout-remove timer)
1526;; (setq timer nil))))))))
7932cfab 1527
1528
1529;;; Text
1530
1531(define-simple-dialog create-text (dialog "Text" :default-width 400
1532 :default-height 400)
1533 (make-instance 'text-view :border-width 10 :parent dialog :visible t))
0d07716f 1534
0d07716f 1535;;; Toggle buttons
1536
35ec512c 1537(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1538 (make-instance 'v-box
1539 :border-width 10 :spacing 10 :parent dialog :show-all t
1540 :children (loop
1541 for n from 1 to 3
1542 collect (make-instance 'toggle-button
1543 :label (format nil "Button~D" (1+ n))))))
0d07716f 1544
1545
1546
1547;;; Toolbar test
1548
35ec512c 1549;; TODO: style properties
1550(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1551 (let ((toolbar (make-instance 'toolbar :parent window)))
1552; (setf (toolbar-relief toolbar) :none)
0d07716f 1553
35ec512c 1554 ;; Insert a stock item
1555 (toolbar-append toolbar "gtk-quit"
1556 :tooltip-text "Destroy toolbar"
1557 :tooltip-private-text "Toolbar/Quit"
1558 :callback #'(lambda () (widget-destroy window)))
0d07716f 1559
35ec512c 1560 ;; Image widge as icon
1561 (toolbar-append toolbar "Horizontal"
1562 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
0d07716f 1563 :tooltip-text "Horizontal toolbar layout"
1564 :tooltip-private-text "Toolbar/Horizontal"
1565 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1566
35ec512c 1567 ;; Icon from file
1568 (toolbar-append toolbar "Vertical"
1569 :icon #p"clg:examples;test.xpm"
0d07716f 1570 :tooltip-text "Vertical toolbar layout"
1571 :tooltip-private-text "Toolbar/Vertical"
1572 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1573
35ec512c 1574 (toolbar-append toolbar :space)
0d07716f 1575
35ec512c 1576 ;; Stock icon
1577 (toolbar-append toolbar "Icons"
1578 :icon "gtk-execute"
0d07716f 1579 :tooltip-text "Only show toolbar icons"
1580 :tooltip-private-text "Toolbar/IconsOnly"
1581 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1582
35ec512c 1583 ;; Icon from pixmap data
1584 (toolbar-append toolbar "Text"
1585 :icon gtk-mini-xpm
0d07716f 1586 :tooltip-text "Only show toolbar text"
1587 :tooltip-private-text "Toolbar/TextOnly"
1588 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1589
35ec512c 1590 (toolbar-append toolbar "Both"
0d07716f 1591 :tooltip-text "Show toolbar icons and text"
1592 :tooltip-private-text "Toolbar/Both"
1593 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1594
35ec512c 1595 (toolbar-append toolbar :space)
0d07716f 1596
35ec512c 1597 (toolbar-append toolbar (make-instance 'entry)
1598 :tooltip-text "This is an unusable GtkEntry"
0d07716f 1599 :tooltip-private-text "Hey don't click me!")
1600
35ec512c 1601 (toolbar-append toolbar :space)
0d07716f 1602
35ec512c 1603;; (toolbar-append-item
1604;; toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1605;; :tooltip-text "Use small spaces"
1606;; :tooltip-private-text "Toolbar/Small"
1607;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
0d07716f 1608
35ec512c 1609;; (toolbar-append-item
1610;; toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1611;; :tooltip-text "Use big spaces"
1612;; :tooltip-private-text "Toolbar/Big"
1613;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
0d07716f 1614
35ec512c 1615;; (toolbar-append toolbar :space)
0d07716f 1616
35ec512c 1617 (toolbar-append
1618 toolbar "Enable"
0d07716f 1619 :tooltip-text "Enable tooltips"
1620 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1621
35ec512c 1622 (toolbar-append
1623 toolbar "Disable"
0d07716f 1624 :tooltip-text "Disable tooltips"
1625 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1626
35ec512c 1627 (toolbar-append toolbar :space)
0d07716f 1628
35ec512c 1629;; (toolbar-append-item
1630;; toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1631;; :tooltip-text "Show borders"
1632;; :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
0d07716f 1633
35ec512c 1634;; (toolbar-append-item
1635;; toolbar
1636;; "Borderless" (pixmap-new "clg:examples;test.xpm")
1637;; :tooltip-text "Hide borders"
1638;; :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1639
1640;; (toolbar-append toolbar :space)
1641
1642;; (toolbar-append-item
1643;; toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1644;; :tooltip-text "Empty spaces"
1645;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1646
1647;; (toolbar-append-item
1648;; toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1649;; :tooltip-text "Lines in spaces"
1650;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
4fb50b71 1651
35ec512c 1652 ))
0d07716f 1653
1654
1655
1656;;; Tooltips test
1657
35ec512c 1658;; (define-standard-dialog create-tooltips "Tooltips"
1659;; (setf
1660;; (window-allow-grow-p window) t
1661;; (window-allow-shrink-p window) nil
1662;; (window-auto-shrink-p window) t
1663;; (widget-width window) 200
1664;; (container-border-width main-box) 10
1665;; (box-spacing main-box) 10)
1666
1667;; (let ((tooltips (tooltips-new)))
1668;; (flet ((create-button (label tip-text tip-private)
1669;; (let ((button (make-instance 'toggle-button
1670;; :label label :parent main-box)))
1671;; (tooltips-set-tip tooltips button tip-text tip-private)
1672;; button)))
1673;; (create-button "button1" "This is button 1" "ContextHelp/button/1")
1674;; (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")
1675
1676;; (let* ((toggle (create-button "Override TipSQuery Label"
1677;; "Toggle TipsQuery view" "Hi msw! ;)"))
1678;; (box (make-instance 'v-box
1679;; :homogeneous nil :spacing 5 :border-width 5
1680;; :parent (make-instance 'frame
1681;; :label "ToolTips Inspector"
1682;; :label-xalign 0.5 :border-width 0
1683;; :parent main-box)))
1684;; (button (make-instance 'button :label "[?]" :parent box))
1685;; (tips-query (make-instance 'tips-query
1686;; :caller button :parent box)))
1687
1688;; (signal-connect
1689;; button 'clicked #'tips-query-start-query :object tips-query)
0d07716f 1690
35ec512c 1691;; (signal-connect
1692;; tips-query 'widget-entered
1693;; #'(lambda (widget tip-text tip-private)
1694;; (declare (ignore widget tip-private))
1695;; (when (toggle-button-active-p toggle)
1696;; (setf
1697;; (label-label tips-query)
1698;; (if tip-text
1699;; "There is a Tip!"
1700;; "There is no Tip!"))
1701;; (signal-emit-stop tips-query 'widget-entered))))
0d07716f 1702
35ec512c 1703;; (signal-connect
1704;; tips-query 'widget-selected
1705;; #'(lambda (widget tip-text tip-private event)
1706;; (declare (ignore tip-text event))
1707;; (when widget
1708;; (format
1709;; t "Help ~S requested for ~S~%"
1710;; (or tip-private "None") (type-of widget)))
1711;; t))
1712
1713;; (tooltips-set-tip
1714;; tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1715;; (tooltips-set-tip
1716;; tooltips close-button "Push this button to close window"
1717;; "ContextHelp/buttons/Close")))))
7932cfab 1718
1719
1720;;; UI Manager
1721
1722(defvar *ui-description*
1723 '((:menubar "MenuBar"
1724 (:menu "FileMenu"
1725 (:menuitem "New")
1726 (:menuitem "Open")
1727 (:menuitem "Save")
1728 (:menuitem "SaveAs")
1729 :separator
1730 (:menuitem "Quit"))
1731 (:menu "PreferencesMenu"
1732 (:menu "ColorMenu"
1733 (:menuitem "Red")
1734 (:menuitem "Green")
1735 (:menuitem "Blue"))
1736 (:menu "ShapeMenu"
1737 (:menuitem "Square")
1738 (:menuitem "Rectangle")
1739 (:menuitem "Oval"))
1740 (:menuitem "Bold"))
1741 (:menu "HelpMenu"
1742 (:menuitem "About")))
1743 (:toolbar "ToolBar"
1744 (:toolitem "Open")
1745 (:toolitem "Quit")
1746 (:separator "Sep1")
1747 (:toolitem "Logo"))))
1748
1749(define-simple-dialog create-ui-manager (dialog "UI Manager")
1750 (let ((actions
1751 (make-instance 'action-group
1752 :name "Actions"
1753 :action (create-action "FileMenu" nil "_File")
1754 :action (create-action "PreferencesMenu" nil "_Preferences")
1755 :action (create-action "ColorMenu" nil "_Color")
1756 :action (create-action "ShapeMenu" nil "_Shape")
1757 :action (create-action "HelpMenu" nil "_Help")
1758 :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
1759 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file")
1760 :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1761 :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
1762 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit")
1763 :action (create-action "About" nil "_About" "<control>A" "About")
1764 :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1765 :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1766 :actions (create-radio-actions
1767 '(("Red" nil "_Red" "<control>R" "Blood")
1768 ("Green" nil "_Green" "<control>G" "Grass")
1769 ("Blue" nil "_Blue" "<control>B" "Sky"))
1770 "Green")
1771 :actions (create-radio-actions
1772 '(("Square" nil "_Square" "<control>S" "Square")
1773 ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1774 ("Oval" nil "_Oval" "<control>O" "Egg")))))
1775 (ui (make-instance 'ui-manager)))
1776
1777 (ui-manager-insert-action-group ui actions)
1778 (ui-manager-add-ui ui *ui-description*)
1779
1780 (window-add-accel-group dialog (ui-manager-accel-group ui))
1781
1782 (make-instance 'v-box
1783 :parent dialog :show-all t
1784 :child (list
1785 (ui-manager-get-widget ui "/MenuBar")
1786 :expand nil :fill nil)
1787 :child (list
1788 (ui-manager-get-widget ui "/ToolBar")
1789 :expand nil :fill nil)
1790 :child (make-instance 'label
1791 :label "Type <alt> to start"
1792 :xalign 0.5 :yalign 0.5
1793 :width-request 200 :height-request 200))))
0d07716f 1794
1795
1796
0d07716f 1797;;; Main window
1798
1799(defun create-main-window ()
35ec512c 1800;; (rc-parse "clg:examples;testgtkrc2")
1801;; (rc-parse "clg:examples;testgtkrc")
4fb50b71 1802
1803 (let* ((button-specs
0d07716f 1804 '(("button box" create-button-box)
35ec512c 1805 ("buttons" create-buttons)
1806 ("calendar" create-calendar)
1807 ("check buttons" create-check-buttons)
35ec512c 1808 ("color selection" create-color-selection)
35ec512c 1809;; ("cursors" #|create-cursors|#)
1810 ("dialog" create-dialog)
1811;; ; ("dnd")
1812 ("entry" create-entry)
1813;; ("event watcher")
36c95ad8 1814 ("enxpander" create-expander)
35ec512c 1815 ("file chooser" create-file-chooser)
1816;; ("font selection")
1817;; ("handle box" create-handle-box)
1818 ("image" create-image)
1819;; ("item factory")
1820 ("labels" create-labels)
1821 ("layout" create-layout)
549265c1 1822 ("list" create-list)
0d07716f 1823 ("menus" create-menus)
35ec512c 1824;; ("modal window")
1825 ("notebook" create-notebook)
1826 ("panes" create-panes)
35ec512c 1827;; ("progress bar" #|create-progress-bar|#)
1828 ("radio buttons" create-radio-buttons)
1829 ("range controls" create-range-controls)
1830;; ("rc file")
1831 ("reparent" create-reparent)
1832 ("rulers" create-rulers)
1833;; ("saved position")
1834 ("scrolled windows" create-scrolled-windows)
1835;; ("shapes" create-shapes)
1836 ("spinbutton" create-spins)
5ff67599 1837 ("statusbar" create-statusbar)
35ec512c 1838;; ("test idle" create-idle-test)
1839;; ("test mainloop")
1840;; ("test scrolling")
1841;; ("test selection")
1842;; ("test timeout" create-timeout-test)
7932cfab 1843 ("text" create-text)
35ec512c 1844 ("toggle buttons" create-toggle-buttons)
1845 ("toolbar" create-toolbar)
1846;; ("tooltips" create-tooltips)
1847;; ("tree" #|create-tree|#)
7932cfab 1848 ("UI manager" create-ui-manager)
35ec512c 1849))
1850 (main-window (make-instance 'window
1851 :title "testgtk.lisp" :name "main_window"
1852 :default-width 200 :default-height 400
1853 :allow-grow t :allow-shrink nil))
1854 (scrolled-window (make-instance 'scrolled-window
1855 :hscrollbar-policy :automatic
1856 :vscrollbar-policy :automatic
1857 :border-width 10))
1858 (close-button (make-instance 'button
1859 :label "close" :can-default t
1860 :signal (list 'clicked #'widget-destroy
1861 :object main-window))))
0d07716f 1862
1863 ;; Main box
35ec512c 1864 (make-instance 'v-box
0d07716f 1865 :parent main-window
35ec512c 1866 :child-args '(:expand nil)
1867 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1868 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1869 :child (list scrolled-window :expand t)
1870 :child (make-instance 'h-separator)
1871 :child (make-instance 'v-box
1872 :homogeneous nil :spacing 10 :border-width 10
1873 :child close-button))
1874
1875 (let ((content-box
1876 (make-instance 'v-box
1877 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1878 :children (mapcar #'(lambda (spec)
1879 (apply #'create-button spec))
1880 button-specs))))
1881 (scrolled-window-add-with-viewport scrolled-window content-box))
0d07716f 1882
35ec512c 1883 (widget-grab-focus close-button)
0d07716f 1884 (widget-show-all main-window)
1885 main-window))
1886
35ec512c 1887(clg-init)
1888(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).