~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Bug fix
[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
33f468b7 18;; $Id: testgtk.lisp,v 1.11 2004-12-17 00:45:00 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)
bdc1babf 58 ,@body
59 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
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))))
33f468b7 241 (table-attach table button column (1+ column) row (1+ row)
242 :options '(:expand :fill)))))
704a1de4 243 (widget-show-all table)))
560af5c5 244
245
246;; Calenadar
247
704a1de4 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)))
560af5c5 252
253
254;;; Check buttons
255
704a1de4 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)))))
560af5c5 263
264
265
266;;; Color selection
267
704a1de4 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))))
560af5c5 296
704a1de4 297 (signal-connect dialog :cancel #'widget-destroy :object t)))
560af5c5 298
560af5c5 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
560af5c5 306
613fb570 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)))
196fe1e9 314
560af5c5 315
196fe1e9 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))
613fb570 320; (label (create-label "Cursor Value : "))
196fe1e9 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)))))
560af5c5 390
391
392
393;;; Dialog
394
704a1de4 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))))))
560af5c5 414
704a1de4 415 (if (widget-visible-p dialog)
416 (widget-hide dialog)
417 (widget-show dialog))))
560af5c5 418
419
420;; Entry
421
704a1de4 422(define-simple-dialog create-entry (dialog "Entry")
423 (let ((main (make-instance 'v-box
424 :border-width 10 :spacing 10 :parent dialog)))
196fe1e9 425
704a1de4 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)
196fe1e9 431
613fb570 432 (let ((combo (make-instance 'combo-box-entry
704a1de4 433 :parent main
613fb570 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)))
704a1de4 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)))
560af5c5 461
560af5c5 462
96b68e83 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
560af5c5 473
704a1de4 474;; File chooser dialog
560af5c5 475
704a1de4 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))))
560af5c5 482
483
484
485;;; Handle box
486
704a1de4 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)))
560af5c5 493
704a1de4 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)))
560af5c5 498
704a1de4 499;; (toolbar-append-space toolbar)
560af5c5 500
704a1de4 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)))
560af5c5 505
704a1de4 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)))
560af5c5 510
704a1de4 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)))
560af5c5 515
704a1de4 516;; (toolbar-append-space toolbar)
560af5c5 517
704a1de4 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)))
560af5c5 522
704a1de4 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)))
560af5c5 527
704a1de4 528;; (toolbar-append-space toolbar)
560af5c5 529
704a1de4 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)))
560af5c5 534
704a1de4 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)))
560af5c5 539
704a1de4 540;; (toolbar-append-space toolbar)
560af5c5 541
704a1de4 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)))
560af5c5 546
704a1de4 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)))
560af5c5 551
704a1de4 552;; toolbar))
560af5c5 553
554
704a1de4 555;; (defun handle-box-child-signal (handle-box child action)
556;; (format t "~S: child ~S ~A~%" handle-box child action))
560af5c5 557
558
704a1de4 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)
560af5c5 566
613fb570 567;; (container-add v-box (create-label "Above"))
704a1de4 568;; (container-add v-box (hseparator-new))
560af5c5 569
704a1de4 570;; (let ((hbox (hbox-new nil 10)))
571;; (container-add v-box hbox)
560af5c5 572
704a1de4 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")))
613fb570 606;; (container-add handle-box2 (create-label "Foo!")))))
560af5c5 607
704a1de4 608;; (container-add v-box (hseparator-new))
613fb570 609;; (container-add v-box (create-label "Below"))))
704a1de4 610
611;;; Image
560af5c5 612
704a1de4 613(define-toplevel create-image (window "Image")
614 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5 615
616
617;;; Labels
618
704a1de4 619(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9 620 (flet ((create-label-in-frame (frame-label label-text &rest args)
621 (list
622 (make-instance 'frame
623 :label frame-label
704a1de4 624 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
196fe1e9 625 :fill nil :expand nil)))
704a1de4 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"
560af5c5 633"This is a Multi-line label.
634Second line
196fe1e9 635Third line")
704a1de4 636 :child (create-label-in-frame "Left Justified Label"
560af5c5 637"This is a Left-Justified
638Multi-line.
196fe1e9 639Third line"
704a1de4 640 :justify :left)
641 :child (create-label-in-frame "Right Justified Label"
560af5c5 642"This is a Right-Justified
643Multi-line.
196fe1e9 644Third line"
704a1de4 645 :justify :right))
646 :child (make-instance 'v-box
647 :spacing 5
648 :child (create-label-in-frame "Line wrapped label"
560af5c5 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.
196fe1e9 650 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4 651 :wrap t)
652
653 :child (create-label-in-frame "Filled, wrapped label"
560af5c5 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.
196fe1e9 656 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4 657 :justify :fill :wrap t)
658
659 :child (create-label-in-frame "Underlined label"
560af5c5 660"This label is underlined!
196fe1e9 661This one is underlined (こんにちは) in quite a funky fashion"
704a1de4 662 :justify :left
663 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
560af5c5 664
665
666;;; Layout
667
704a1de4 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)
196fe1e9 696 (let ((layout (make-instance 'layout
697 :parent (make-instance 'scrolled-window :parent window)
704a1de4 698 :width 1600 :height 128000 :events '(:exposure-mask)
699;; :signal (list 'expose-event #'layout-expose :object t)
700 )))
196fe1e9 701
702 (with-slots (hadjustment vadjustment) layout
703 (setf
704 (adjustment-step-increment hadjustment) 10.0
705 (adjustment-step-increment vadjustment) 10.0))
560af5c5 706
707 (dotimes (i 16)
708 (dotimes (j 16)
704a1de4 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))))))
560af5c5 714
704a1de4 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)))))))
196fe1e9 722
560af5c5 723
724
725;;; List
726
21f6214a 727(define-simple-dialog create-list (dialog "List" :default-height 400)
d975a970 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)))
560af5c5 734
21f6214a 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))
d975a970 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))))
560af5c5 816
817
818;; Menus
819
820(defun create-menu (depth tearoff)
821 (unless (zerop depth)
704a1de4 822 (let ((menu (make-instance 'menu)))
560af5c5 823 (when tearoff
704a1de4 824 (let ((menu-item (make-instance 'tearoff-menu-item)))
825 (menu-shell-append menu menu-item)))
560af5c5 826 (let ((group nil))
827 (dotimes (i 5)
704a1de4 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))
560af5c5 834 (unless (zerop (mod depth 2))
704a1de4 835 (setf (check-menu-item-active-p menu-item) t))
836 (menu-shell-append menu menu-item)
560af5c5 837 (when (= i 3)
704a1de4 838 (setf (widget-sensitive-p menu-item) nil))
839 (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
196fe1e9 840 menu)))
560af5c5 841
842
704a1de4 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
613fb570 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))))
560af5c5 870
613fb570 871 (widget-show-all main)))
560af5c5 872
873
874;;; Notebook
875
704a1de4 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))))
560af5c5 928
560af5c5 929
704a1de4 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))
613fb570 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)))
704a1de4 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)))
560af5c5 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))
560af5c5 1044 (container-remove paned child)
1045 (if is-child1-p
1046 (paned-pack1 paned child (not resize) shrink)
196fe1e9 1047 (paned-pack2 paned child (not resize) shrink)))))
560af5c5 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))
560af5c5 1056 (container-remove paned child)
1057 (if is-child1-p
1058 (paned-pack1 paned child resize (not shrink))
196fe1e9 1059 (paned-pack2 paned child resize (not shrink))))))
560af5c5 1060
1061(defun create-pane-options (paned frame-label label1 label2)
704a1de4 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)))
560af5c5 1065
33f468b7 1066 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
704a1de4 1067 (let ((check-button (make-instance 'check-button :label "Resize")))
33f468b7 1068 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
560af5c5 1069 (signal-connect
1070 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
704a1de4 1071 (let ((check-button (make-instance 'check-button :label "Shrink")))
33f468b7 1072 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
560af5c5 1073 (setf (toggle-button-active-p check-button) t)
1074 (signal-connect
1075 check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1076
33f468b7 1077 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
704a1de4 1078 (let ((check-button (make-instance 'check-button :label "Resize")))
33f468b7 1079 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
560af5c5 1080 (setf (toggle-button-active-p check-button) t)
1081 (signal-connect
1082 check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
704a1de4 1083 (let ((check-button (make-instance 'check-button :label "Shrink")))
33f468b7 1084 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
560af5c5 1085 (setf (toggle-button-active-p check-button) t)
1086 (signal-connect
1087 check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
560af5c5 1088 frame))
1089
704a1de4 1090(define-toplevel create-panes (window "Panes")
1091 (let* ((hpaned (make-instance 'h-paned
196fe1e9 1092 :child1 (make-instance 'frame
704a1de4 1093 :width-request 60 :height-request 60
1094 :shadow-type :in
613fb570 1095 :child (make-instance 'buttun :label "Hi there"))
704a1de4 1096 :child2 (make-instance 'frame
1097 :width-request 80 :height-request 60
1098 :shadow-type :in)))
1099 (vpaned (make-instance 'v-paned
196fe1e9 1100 :border-width 5
1101 :child1 hpaned
1102 :child2 (make-instance 'frame
704a1de4 1103 :width-request 80 :height-request 60
1104 :shadow-type :in))))
196fe1e9 1105
704a1de4 1106 (make-instance 'v-box
196fe1e9 1107 :parent window
704a1de4 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"))))
560af5c5 1112
1113
560af5c5 1114;;; Progress bar
1115
196fe1e9 1116
560af5c5 1117
1118
1119;;; Radio buttons
1120
704a1de4 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)))
560af5c5 1125
1126
1127;;; Rangle controls
1128
704a1de4 1129(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1130 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 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))))
560af5c5 1138
1139
1140;;; Reparent test
1141
704a1de4 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")))
560af5c5 1146
704a1de4 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)))
560af5c5 1157
704a1de4 1158 (box-pack-start (create-frame "Frame 1") label nil t 0)
1159 (create-frame "Frame 2"))
1160 (widget-show-all main)))
560af5c5 1161
1162
1163;;; Rulers
1164
704a1de4 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
33f468b7 1174 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1175 (h-ruler (make-instance 'h-ruler
704a1de4 1176 :metric :centimeters :lower 100.0d0 :upper 0.0d0
33f468b7 1177 :position 0.0d0 :max-size 20.0d0))
1178 (v-ruler (make-instance 'v-ruler
704a1de4 1179 :lower 5.0d0 :upper 15.0d0
1180 :position 0.0d0 :max-size 20.0d0)))
33f468b7 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)))
560af5c5 1187
1188
1189;;; Scrolled window
1190
704a1de4 1191(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1192 :default-width 300
1193 :default-height 300)
196fe1e9 1194 (let* ((scrolled-window
1195 (make-instance 'scrolled-window
704a1de4 1196 :parent dialog :border-width 10
1197 :vscrollbar-policy :automatic
196fe1e9 1198 :hscrollbar-policy :automatic))
1199 (table
1200 (make-instance 'table
704a1de4 1201 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1202 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1203 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1204
560af5c5 1205 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1206 (dotimes (i 20)
1207 (dotimes (j 20)
1208 (let ((button
704a1de4 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)))
560af5c5 1213
1214
33f468b7 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
560af5c5 1251;;; Shapes
1252
704a1de4 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)))
196fe1e9 1261
704a1de4 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)
196fe1e9 1270
704a1de4 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))
560af5c5 1289
704a1de4 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)))
560af5c5 1300
704a1de4 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)))))
560af5c5 1333
1334
1335
1336;;; Spin buttons
1337
704a1de4 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 : "
c775862e 1358 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
704a1de4 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)))
560af5c5 1434
704a1de4 1435
c775862e 1436;;; Statusbar
560af5c5 1437
c775862e 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)))
560af5c5 1472
1473
1474;;; Idle test
1475
bdc1babf 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))))
560af5c5 1483
bdc1babf 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))))))
560af5c5 1508
bdc1babf 1509 (dialog-add-button dialog "Stop"
1510 #'(lambda ()
1511 (when idle
1512 (idle-remove idle)
1513 (setq idle nil))))))
560af5c5 1514
1515
1516
1517;;; Timeout test
1518
bdc1babf 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))))))
dddfc333 1542
1543
1544;;; Text
1545
1546(define-simple-dialog create-text (dialog "Text" :default-width 400
1547 :default-height 400)
33f468b7 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
560af5c5 1628
560af5c5 1629;;; Toggle buttons
1630
704a1de4 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))))))
560af5c5 1638
1639
1640
1641;;; Toolbar test
1642
704a1de4 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)
560af5c5 1647
704a1de4 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)))
560af5c5 1653
704a1de4 1654 ;; Image widge as icon
1655 (toolbar-append toolbar "Horizontal"
1656 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
560af5c5 1657 :tooltip-text "Horizontal toolbar layout"
1658 :tooltip-private-text "Toolbar/Horizontal"
1659 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1660
704a1de4 1661 ;; Icon from file
1662 (toolbar-append toolbar "Vertical"
1663 :icon #p"clg:examples;test.xpm"
560af5c5 1664 :tooltip-text "Vertical toolbar layout"
1665 :tooltip-private-text "Toolbar/Vertical"
1666 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1667
704a1de4 1668 (toolbar-append toolbar :space)
560af5c5 1669
704a1de4 1670 ;; Stock icon
1671 (toolbar-append toolbar "Icons"
1672 :icon "gtk-execute"
560af5c5 1673 :tooltip-text "Only show toolbar icons"
1674 :tooltip-private-text "Toolbar/IconsOnly"
1675 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1676
704a1de4 1677 ;; Icon from pixmap data
1678 (toolbar-append toolbar "Text"
1679 :icon gtk-mini-xpm
560af5c5 1680 :tooltip-text "Only show toolbar text"
1681 :tooltip-private-text "Toolbar/TextOnly"
1682 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1683
704a1de4 1684 (toolbar-append toolbar "Both"
560af5c5 1685 :tooltip-text "Show toolbar icons and text"
1686 :tooltip-private-text "Toolbar/Both"
1687 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1688
704a1de4 1689 (toolbar-append toolbar :space)
560af5c5 1690
704a1de4 1691 (toolbar-append toolbar (make-instance 'entry)
1692 :tooltip-text "This is an unusable GtkEntry"
560af5c5 1693 :tooltip-private-text "Hey don't click me!")
1694
704a1de4 1695 (toolbar-append toolbar :space)
560af5c5 1696
704a1de4 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)))
560af5c5 1702
704a1de4 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)))
560af5c5 1708
704a1de4 1709;; (toolbar-append toolbar :space)
560af5c5 1710
704a1de4 1711 (toolbar-append
1712 toolbar "Enable"
560af5c5 1713 :tooltip-text "Enable tooltips"
1714 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1715
704a1de4 1716 (toolbar-append
1717 toolbar "Disable"
560af5c5 1718 :tooltip-text "Disable tooltips"
1719 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1720
704a1de4 1721 (toolbar-append toolbar :space)
560af5c5 1722
704a1de4 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)))
560af5c5 1727
704a1de4 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)))
196fe1e9 1745
704a1de4 1746 ))
560af5c5 1747
1748
1749
1750;;; Tooltips test
1751
bdc1babf 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")
33f468b7 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")))))
dddfc333 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
33f468b7 1793(define-toplevel create-ui-manager (window "UI Manager")
dddfc333 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")
33f468b7 1803 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
dddfc333 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")
33f468b7 1806 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
dddfc333 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
33f468b7 1824 (window-add-accel-group window (ui-manager-accel-group ui))
dddfc333 1825
1826 (make-instance 'v-box
33f468b7 1827 :parent window :show-all t
dddfc333 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))))
560af5c5 1838
1839
1840
560af5c5 1841;;; Main window
1842
1843(defun create-main-window ()
704a1de4 1844;; (rc-parse "clg:examples;testgtkrc2")
1845;; (rc-parse "clg:examples;testgtkrc")
196fe1e9 1846
1847 (let* ((button-specs
560af5c5 1848 '(("button box" create-button-box)
704a1de4 1849 ("buttons" create-buttons)
1850 ("calendar" create-calendar)
1851 ("check buttons" create-check-buttons)
704a1de4 1852 ("color selection" create-color-selection)
704a1de4 1853;; ("cursors" #|create-cursors|#)
1854 ("dialog" create-dialog)
1855;; ; ("dnd")
1856 ("entry" create-entry)
1857;; ("event watcher")
96b68e83 1858 ("enxpander" create-expander)
704a1de4 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)
21f6214a 1866 ("list" create-list)
560af5c5 1867 ("menus" create-menus)
704a1de4 1868;; ("modal window")
1869 ("notebook" create-notebook)
1870 ("panes" create-panes)
704a1de4 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)
33f468b7 1879 ("size group" create-size-group)
704a1de4 1880;; ("shapes" create-shapes)
1881 ("spinbutton" create-spins)
c775862e 1882 ("statusbar" create-statusbar)
bdc1babf 1883 ("test idle" create-idle-test)
704a1de4 1884;; ("test mainloop")
1885;; ("test scrolling")
1886;; ("test selection")
bdc1babf 1887 ("test timeout" create-timeout-test)
dddfc333 1888 ("text" create-text)
704a1de4 1889 ("toggle buttons" create-toggle-buttons)
1890 ("toolbar" create-toolbar)
bdc1babf 1891 ("tooltips" create-tooltips)
704a1de4 1892;; ("tree" #|create-tree|#)
dddfc333 1893 ("UI manager" create-ui-manager)
704a1de4 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))))
560af5c5 1907
1908 ;; Main box
704a1de4 1909 (make-instance 'v-box
560af5c5 1910 :parent main-window
704a1de4 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))
560af5c5 1927
704a1de4 1928 (widget-grab-focus close-button)
560af5c5 1929 (widget-show-all main-window)
1930 main-window))
1931
704a1de4 1932(clg-init)
1933(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).