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