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
560af5c5 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
96b68e83 18;; $Id: testgtk.lisp,v 1.9 2004-12-05 00:06:41 espen Exp $
560af5c5 19
20
704a1de4 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
560af5c5 23
704a1de4 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))
560af5c5 30 (defun ,name ()
704a1de4 31 (unless ,window
32 (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
33 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
560af5c5 34 ,@body)
35
704a1de4 36 (if (not (widget-visible-p ,window))
37 (widget-show-all ,window)
38 (widget-hide ,window)))))
39
560af5c5 40
704a1de4 41(defmacro define-dialog (name (dialog title &optional (class 'dialog)
42 &rest initargs)
43 &body body)
44 `(let ((,dialog nil))
560af5c5 45 (defun ,name ()
704a1de4 46 (unless ,dialog
47 (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
48 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
49 ,@body)
560af5c5 50
704a1de4 51 (if (not (widget-visible-p ,dialog))
52 (widget-show ,dialog)
53 (widget-hide ,dialog)))))
560af5c5 54
55
704a1de4 56(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
57 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
96b68e83 58 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)
704a1de4 59 ,@body))
560af5c5 60
61
560af5c5 62
63;;; Pixmaps used in some of the tests
64
65(defvar gtk-mini-xpm
196fe1e9 66 #("15 20 17 1"
560af5c5 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
196fe1e9 106 #("16 16 6 1"
560af5c5 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
196fe1e9 131 #("16 16 4 1"
560af5c5 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
196fe1e9 154 #("16 16 4 1"
560af5c5 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
196fe1e9 180(defun create-bbox-in-frame (class frame-label spacing width height layout)
704a1de4 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
dddfc333 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))))
704a1de4 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)))))))
196fe1e9 218
219
220;; Buttons
221
704a1de4 222(define-simple-dialog create-buttons (dialog "Buttons")
196fe1e9 223 (let ((table (make-instance 'table
704a1de4 224 :n-rows 3 :n-columns 3 :homogeneous nil
196fe1e9 225 :row-spacing 5 :column-spacing 5 :border-width 10
704a1de4 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
196fe1e9 232 (dotimes (column 3)
233 (dotimes (row 3)
704a1de4 234 (let ((button (nth (+ (* 3 row) column) buttons))
235 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
196fe1e9 236 (signal-connect button 'clicked
237 #'(lambda ()
238 (if (widget-visible-p button+1)
239 (widget-hide button+1)
240 (widget-show button+1))))
704a1de4 241 (table-attach table button column (1+ column) row (1+ row)))))
242 (widget-show-all table)))
560af5c5 243
244
245;; Calenadar
246
704a1de4 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)))
560af5c5 251
252
253;;; Check buttons
254
704a1de4 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)))))
560af5c5 262
263
264
265;;; Color selection
266
704a1de4 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))))
560af5c5 295
704a1de4 296 (signal-connect dialog :cancel #'widget-destroy :object t)))
560af5c5 297
560af5c5 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
560af5c5 305
613fb570 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)))
196fe1e9 313
560af5c5 314
196fe1e9 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))
613fb570 319; (label (create-label "Cursor Value : "))
196fe1e9 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)))))
560af5c5 389
390
391
392;;; Dialog
393
704a1de4 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))))))
560af5c5 413
704a1de4 414 (if (widget-visible-p dialog)
415 (widget-hide dialog)
416 (widget-show dialog))))
560af5c5 417
418
419;; Entry
420
704a1de4 421(define-simple-dialog create-entry (dialog "Entry")
422 (let ((main (make-instance 'v-box
423 :border-width 10 :spacing 10 :parent dialog)))
196fe1e9 424
704a1de4 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)
196fe1e9 430
613fb570 431 (let ((combo (make-instance 'combo-box-entry
704a1de4 432 :parent main
613fb570 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)))
704a1de4 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)))
560af5c5 460
560af5c5 461
96b68e83 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
560af5c5 472
704a1de4 473;; File chooser dialog
560af5c5 474
704a1de4 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))))
560af5c5 481
482
483
484;;; Handle box
485
704a1de4 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)))
560af5c5 492
704a1de4 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)))
560af5c5 497
704a1de4 498;; (toolbar-append-space toolbar)
560af5c5 499
704a1de4 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)))
560af5c5 504
704a1de4 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)))
560af5c5 509
704a1de4 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)))
560af5c5 514
704a1de4 515;; (toolbar-append-space toolbar)
560af5c5 516
704a1de4 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)))
560af5c5 521
704a1de4 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)))
560af5c5 526
704a1de4 527;; (toolbar-append-space toolbar)
560af5c5 528
704a1de4 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)))
560af5c5 533
704a1de4 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)))
560af5c5 538
704a1de4 539;; (toolbar-append-space toolbar)
560af5c5 540
704a1de4 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)))
560af5c5 545
704a1de4 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)))
560af5c5 550
704a1de4 551;; toolbar))
560af5c5 552
553
704a1de4 554;; (defun handle-box-child-signal (handle-box child action)
555;; (format t "~S: child ~S ~A~%" handle-box child action))
560af5c5 556
557
704a1de4 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)
560af5c5 565
613fb570 566;; (container-add v-box (create-label "Above"))
704a1de4 567;; (container-add v-box (hseparator-new))
560af5c5 568
704a1de4 569;; (let ((hbox (hbox-new nil 10)))
570;; (container-add v-box hbox)
560af5c5 571
704a1de4 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")))
613fb570 605;; (container-add handle-box2 (create-label "Foo!")))))
560af5c5 606
704a1de4 607;; (container-add v-box (hseparator-new))
613fb570 608;; (container-add v-box (create-label "Below"))))
704a1de4 609
610;;; Image
560af5c5 611
704a1de4 612(define-toplevel create-image (window "Image")
613 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5 614
615
616;;; Labels
617
704a1de4 618(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9 619 (flet ((create-label-in-frame (frame-label label-text &rest args)
620 (list
621 (make-instance 'frame
622 :label frame-label
704a1de4 623 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
196fe1e9 624 :fill nil :expand nil)))
704a1de4 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"
560af5c5 632"This is a Multi-line label.
633Second line
196fe1e9 634Third line")
704a1de4 635 :child (create-label-in-frame "Left Justified Label"
560af5c5 636"This is a Left-Justified
637Multi-line.
196fe1e9 638Third line"
704a1de4 639 :justify :left)
640 :child (create-label-in-frame "Right Justified Label"
560af5c5 641"This is a Right-Justified
642Multi-line.
196fe1e9 643Third line"
704a1de4 644 :justify :right))
645 :child (make-instance 'v-box
646 :spacing 5
647 :child (create-label-in-frame "Line wrapped label"
560af5c5 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.
196fe1e9 649 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4 650 :wrap t)
651
652 :child (create-label-in-frame "Filled, wrapped label"
560af5c5 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.
196fe1e9 655 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4 656 :justify :fill :wrap t)
657
658 :child (create-label-in-frame "Underlined label"
560af5c5 659"This label is underlined!
196fe1e9 660This one is underlined (こんにちは) in quite a funky fashion"
704a1de4 661 :justify :left
662 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
560af5c5 663
664
665;;; Layout
666
704a1de4 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)
196fe1e9 695 (let ((layout (make-instance 'layout
696 :parent (make-instance 'scrolled-window :parent window)
704a1de4 697 :width 1600 :height 128000 :events '(:exposure-mask)
698;; :signal (list 'expose-event #'layout-expose :object t)
699 )))
196fe1e9 700
701 (with-slots (hadjustment vadjustment) layout
702 (setf
703 (adjustment-step-increment hadjustment) 10.0
704 (adjustment-step-increment vadjustment) 10.0))
560af5c5 705
706 (dotimes (i 16)
707 (dotimes (j 16)
704a1de4 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))))))
560af5c5 713
704a1de4 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)))))))
196fe1e9 721
560af5c5 722
723
724;;; List
725
21f6214a 726(define-simple-dialog create-list (dialog "List" :default-height 400)
d975a970 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)))
560af5c5 733
21f6214a 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))
d975a970 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))))
560af5c5 815
816
817;; Menus
818
819(defun create-menu (depth tearoff)
820 (unless (zerop depth)
704a1de4 821 (let ((menu (make-instance 'menu)))
560af5c5 822 (when tearoff
704a1de4 823 (let ((menu-item (make-instance 'tearoff-menu-item)))
824 (menu-shell-append menu menu-item)))
560af5c5 825 (let ((group nil))
826 (dotimes (i 5)
704a1de4 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))
560af5c5 833 (unless (zerop (mod depth 2))
704a1de4 834 (setf (check-menu-item-active-p menu-item) t))
835 (menu-shell-append menu menu-item)
560af5c5 836 (when (= i 3)
704a1de4 837 (setf (widget-sensitive-p menu-item) nil))
838 (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
196fe1e9 839 menu)))
560af5c5 840
841
704a1de4 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
613fb570 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))))
560af5c5 869
613fb570 870 (widget-show-all main)))
560af5c5 871
872
873;;; Notebook
874
704a1de4 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))))
560af5c5 927
560af5c5 928
704a1de4 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))
613fb570 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)))
704a1de4 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)))
560af5c5 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))
560af5c5 1043 (container-remove paned child)
1044 (if is-child1-p
1045 (paned-pack1 paned child (not resize) shrink)
196fe1e9 1046 (paned-pack2 paned child (not resize) shrink)))))
560af5c5 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))
560af5c5 1055 (container-remove paned child)
1056 (if is-child1-p
1057 (paned-pack1 paned child resize (not shrink))
196fe1e9 1058 (paned-pack2 paned child resize (not shrink))))))
560af5c5 1059
1060(defun create-pane-options (paned frame-label label1 label2)
704a1de4 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)))
560af5c5 1064
613fb570 1065 (table-attach table (create-label label1) 0 1 0 1)
704a1de4 1066 (let ((check-button (make-instance 'check-button :label "Resize")))
560af5c5 1067 (table-attach table check-button 0 1 1 2)
1068 (signal-connect
1069 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
704a1de4 1070 (let ((check-button (make-instance 'check-button :label "Shrink")))
560af5c5 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
613fb570 1076 (table-attach table (create-label label2) 1 2 0 1)
704a1de4 1077 (let ((check-button (make-instance 'check-button :label "Resize")))
560af5c5 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)))
704a1de4 1082 (let ((check-button (make-instance 'check-button :label "Shrink")))
560af5c5 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)))
560af5c5 1087 frame))
1088
704a1de4 1089(define-toplevel create-panes (window "Panes")
1090 (let* ((hpaned (make-instance 'h-paned
196fe1e9 1091 :child1 (make-instance 'frame
704a1de4 1092 :width-request 60 :height-request 60
1093 :shadow-type :in
613fb570 1094 :child (make-instance 'buttun :label "Hi there"))
704a1de4 1095 :child2 (make-instance 'frame
1096 :width-request 80 :height-request 60
1097 :shadow-type :in)))
1098 (vpaned (make-instance 'v-paned
196fe1e9 1099 :border-width 5
1100 :child1 hpaned
1101 :child2 (make-instance 'frame
704a1de4 1102 :width-request 80 :height-request 60
1103 :shadow-type :in))))
196fe1e9 1104
704a1de4 1105 (make-instance 'v-box
196fe1e9 1106 :parent window
704a1de4 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"))))
560af5c5 1111
1112
560af5c5 1113;;; Progress bar
1114
196fe1e9 1115
560af5c5 1116
1117
1118;;; Radio buttons
1119
704a1de4 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)))
560af5c5 1124
1125
1126;;; Rangle controls
1127
704a1de4 1128(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1129 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 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))))
560af5c5 1137
1138
1139;;; Reparent test
1140
704a1de4 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")))
560af5c5 1145
704a1de4 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)))
560af5c5 1156
704a1de4 1157 (box-pack-start (create-frame "Frame 1") label nil t 0)
1158 (create-frame "Frame 2"))
1159 (widget-show-all main)))
560af5c5 1160
1161
1162;;; Rulers
1163
704a1de4 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)
196fe1e9 1178 (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
704a1de4 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)
196fe1e9 1183 (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
560af5c5 1184
1185
1186
1187;;; Scrolled window
1188
704a1de4 1189(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1190 :default-width 300
1191 :default-height 300)
196fe1e9 1192 (let* ((scrolled-window
1193 (make-instance 'scrolled-window
704a1de4 1194 :parent dialog :border-width 10
1195 :vscrollbar-policy :automatic
196fe1e9 1196 :hscrollbar-policy :automatic))
1197 (table
1198 (make-instance 'table
704a1de4 1199 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1200 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1201 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1202
560af5c5 1203 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1204 (dotimes (i 20)
1205 (dotimes (j 20)
1206 (let ((button
704a1de4 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)))
560af5c5 1211
1212
1213;;; Shapes
1214
704a1de4 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)))
196fe1e9 1223
704a1de4 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)
196fe1e9 1232
704a1de4 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))
560af5c5 1251
704a1de4 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)))
560af5c5 1262
704a1de4 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)))))
560af5c5 1295
1296
1297
1298;;; Spin buttons
1299
704a1de4 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 : "
c775862e 1320 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
704a1de4 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)))
560af5c5 1396
704a1de4 1397
c775862e 1398;;; Statusbar
560af5c5 1399
c775862e 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)))
560af5c5 1434
1435
1436;;; Idle test
1437
704a1de4 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))))
560af5c5 1447
704a1de4 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))))))))
560af5c5 1475
704a1de4 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))))))))
560af5c5 1486
1487
1488
1489;;; Timeout test
1490
704a1de4 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))))
196fe1e9 1499
704a1de4 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))))))))
dddfc333 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))
560af5c5 1534
560af5c5 1535;;; Toggle buttons
1536
704a1de4 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))))))
560af5c5 1544
1545
1546
1547;;; Toolbar test
1548
704a1de4 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)
560af5c5 1553
704a1de4 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)))
560af5c5 1559
704a1de4 1560 ;; Image widge as icon
1561 (toolbar-append toolbar "Horizontal"
1562 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
560af5c5 1563 :tooltip-text "Horizontal toolbar layout"
1564 :tooltip-private-text "Toolbar/Horizontal"
1565 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1566
704a1de4 1567 ;; Icon from file
1568 (toolbar-append toolbar "Vertical"
1569 :icon #p"clg:examples;test.xpm"
560af5c5 1570 :tooltip-text "Vertical toolbar layout"
1571 :tooltip-private-text "Toolbar/Vertical"
1572 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1573
704a1de4 1574 (toolbar-append toolbar :space)
560af5c5 1575
704a1de4 1576 ;; Stock icon
1577 (toolbar-append toolbar "Icons"
1578 :icon "gtk-execute"
560af5c5 1579 :tooltip-text "Only show toolbar icons"
1580 :tooltip-private-text "Toolbar/IconsOnly"
1581 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1582
704a1de4 1583 ;; Icon from pixmap data
1584 (toolbar-append toolbar "Text"
1585 :icon gtk-mini-xpm
560af5c5 1586 :tooltip-text "Only show toolbar text"
1587 :tooltip-private-text "Toolbar/TextOnly"
1588 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1589
704a1de4 1590 (toolbar-append toolbar "Both"
560af5c5 1591 :tooltip-text "Show toolbar icons and text"
1592 :tooltip-private-text "Toolbar/Both"
1593 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1594
704a1de4 1595 (toolbar-append toolbar :space)
560af5c5 1596
704a1de4 1597 (toolbar-append toolbar (make-instance 'entry)
1598 :tooltip-text "This is an unusable GtkEntry"
560af5c5 1599 :tooltip-private-text "Hey don't click me!")
1600
704a1de4 1601 (toolbar-append toolbar :space)
560af5c5 1602
704a1de4 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)))
560af5c5 1608
704a1de4 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)))
560af5c5 1614
704a1de4 1615;; (toolbar-append toolbar :space)
560af5c5 1616
704a1de4 1617 (toolbar-append
1618 toolbar "Enable"
560af5c5 1619 :tooltip-text "Enable tooltips"
1620 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1621
704a1de4 1622 (toolbar-append
1623 toolbar "Disable"
560af5c5 1624 :tooltip-text "Disable tooltips"
1625 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1626
704a1de4 1627 (toolbar-append toolbar :space)
560af5c5 1628
704a1de4 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)))
560af5c5 1633
704a1de4 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)))
196fe1e9 1651
704a1de4 1652 ))
560af5c5 1653
1654
1655
1656;;; Tooltips test
1657
704a1de4 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)
560af5c5 1690
704a1de4 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))))
560af5c5 1702
704a1de4 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")))))
dddfc333 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))))
560af5c5 1794
1795
1796
560af5c5 1797;;; Main window
1798
1799(defun create-main-window ()
704a1de4 1800;; (rc-parse "clg:examples;testgtkrc2")
1801;; (rc-parse "clg:examples;testgtkrc")
196fe1e9 1802
1803 (let* ((button-specs
560af5c5 1804 '(("button box" create-button-box)
704a1de4 1805 ("buttons" create-buttons)
1806 ("calendar" create-calendar)
1807 ("check buttons" create-check-buttons)
704a1de4 1808 ("color selection" create-color-selection)
704a1de4 1809;; ("cursors" #|create-cursors|#)
1810 ("dialog" create-dialog)
1811;; ; ("dnd")
1812 ("entry" create-entry)
1813;; ("event watcher")
96b68e83 1814 ("enxpander" create-expander)
704a1de4 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)
21f6214a 1822 ("list" create-list)
560af5c5 1823 ("menus" create-menus)
704a1de4 1824;; ("modal window")
1825 ("notebook" create-notebook)
1826 ("panes" create-panes)
704a1de4 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)
c775862e 1837 ("statusbar" create-statusbar)
704a1de4 1838;; ("test idle" create-idle-test)
1839;; ("test mainloop")
1840;; ("test scrolling")
1841;; ("test selection")
1842;; ("test timeout" create-timeout-test)
dddfc333 1843 ("text" create-text)
704a1de4 1844 ("toggle buttons" create-toggle-buttons)
1845 ("toolbar" create-toolbar)
1846;; ("tooltips" create-tooltips)
1847;; ("tree" #|create-tree|#)
dddfc333 1848 ("UI manager" create-ui-manager)
704a1de4 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))))
560af5c5 1862
1863 ;; Main box
704a1de4 1864 (make-instance 'v-box
560af5c5 1865 :parent main-window
704a1de4 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))
560af5c5 1882
704a1de4 1883 (widget-grab-focus close-button)
560af5c5 1884 (widget-show-all main-window)
1885 main-window))
1886
704a1de4 1887(clg-init)
1888(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).