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