~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Added more binding
[clg] / examples / testgtk.lisp
CommitLineData
0d07716f 1;; Common Lisp bindings for GTK+ v2.0
8179fd68 2;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
0d07716f 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
8179fd68 18;; $Id: testgtk.lisp,v 1.15 2005/01/06 21:59:51 espen Exp $
0d07716f 19
20
35ec512c 21;;; Some of the code in this file are really outdatet, but it is
22;;; still the most complete example of how to use the library
0d07716f 23
35ec512c 24
25;(use-package "GTK")
26(in-package "GTK")
27
28(defmacro define-toplevel (name (window title &rest initargs) &body body)
29 `(let ((,window nil))
0d07716f 30 (defun ,name ()
35ec512c 31 (unless ,window
32 (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
33 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
0d07716f 34 ,@body)
35
35ec512c 36 (if (not (widget-visible-p ,window))
37 (widget-show-all ,window)
38 (widget-hide ,window)))))
39
0d07716f 40
35ec512c 41(defmacro define-dialog (name (dialog title &optional (class 'dialog)
42 &rest initargs)
43 &body body)
44 `(let ((,dialog nil))
0d07716f 45 (defun ,name ()
35ec512c 46 (unless ,dialog
47 (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
48 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
49 ,@body)
0d07716f 50
35ec512c 51 (if (not (widget-visible-p ,dialog))
52 (widget-show ,dialog)
53 (widget-hide ,dialog)))))
0d07716f 54
55
35ec512c 56(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
57 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
e025589b 58 ,@body
59 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
0d07716f 60
61
0d07716f 62
63;;; Pixmaps used in some of the tests
64
65(defvar gtk-mini-xpm
4fb50b71 66 #("15 20 17 1"
0d07716f 67 " c None"
68 ". c #14121F"
69 "+ c #278828"
70 "@ c #9B3334"
71 "# c #284C72"
72 "$ c #24692A"
73 "% c #69282E"
74 "& c #37C539"
75 "* c #1D2F4D"
76 "= c #6D7076"
77 "- c #7D8482"
78 "; c #E24A49"
79 "> c #515357"
80 ", c #9B9C9B"
81 "' c #2FA232"
82 ") c #3CE23D"
83 "! c #3B6CCB"
84 " "
85 " ***> "
86 " >.*!!!* "
87 " ***....#*= "
88 " *!*.!!!**!!# "
89 " .!!#*!#*!!!!# "
90 " @%#!.##.*!!$& "
91 " @;%*!*.#!#')) "
92 " @;;@%!!*$&)'' "
93 " @%.%@%$'&)$+' "
94 " @;...@$'*'*)+ "
95 " @;%..@$+*.')$ "
96 " @;%%;;$+..$)# "
97 " @;%%;@$$$'.$# "
98 " %;@@;;$$+))&* "
99 " %;;;@+$&)&* "
100 " %;;@'))+> "
101 " %;@'&# "
102 " >%$$ "
103 " >= "))
104
105(defvar book-closed-xpm
4fb50b71 106 #("16 16 6 1"
0d07716f 107 " c None s None"
108 ". c black"
109 "X c red"
110 "o c yellow"
111 "O c #808080"
112 "# c white"
113 " "
114 " .. "
115 " ..XX. "
116 " ..XXXXX. "
117 " ..XXXXXXXX. "
118 ".ooXXXXXXXXX. "
119 "..ooXXXXXXXXX. "
120 ".X.ooXXXXXXXXX. "
121 ".XX.ooXXXXXX.. "
122 " .XX.ooXXX..#O "
123 " .XX.oo..##OO. "
124 " .XX..##OO.. "
125 " .X.#OO.. "
126 " ..O.. "
127 " .. "
128 " "))
129
130(defvar mini-page-xpm
4fb50b71 131 #("16 16 4 1"
0d07716f 132 " c None s None"
133 ". c black"
134 "X c white"
135 "o c #808080"
136 " "
137 " ....... "
138 " .XXXXX.. "
139 " .XoooX.X. "
140 " .XXXXX.... "
141 " .XooooXoo.o "
142 " .XXXXXXXX.o "
143 " .XooooooX.o "
144 " .XXXXXXXX.o "
145 " .XooooooX.o "
146 " .XXXXXXXX.o "
147 " .XooooooX.o "
148 " .XXXXXXXX.o "
149 " ..........o "
150 " oooooooooo "
151 " "))
152
153(defvar book-open-xpm
4fb50b71 154 #("16 16 4 1"
0d07716f 155 " c None s None"
156 ". c black"
157 "X c #808080"
158 "o c white"
159 " "
160 " .. "
161 " .Xo. ... "
162 " .Xoo. ..oo. "
163 " .Xooo.Xooo... "
164 " .Xooo.oooo.X. "
165 " .Xooo.Xooo.X. "
166 " .Xooo.oooo.X. "
167 " .Xooo.Xooo.X. "
168 " .Xooo.oooo.X. "
169 " .Xoo.Xoo..X. "
170 " .Xo.o..ooX. "
171 " .X..XXXXX. "
172 " ..X....... "
173 " .. "
174 " "))
175
176
177
178;;; Button box
179
4fb50b71 180(defun create-bbox-in-frame (class frame-label spacing width height layout)
35ec512c 181 (declare (ignore width height))
182 (make-instance 'frame
183 :label frame-label
184 :child (make-instance class
185 :border-width 5 :layout-style layout :spacing spacing
8804934b 186 :child (make-instance 'button :stock "gtk-ok")
187 :child (make-instance 'button :stock "gtk-cancel")
188 :child (make-instance 'button :stock "gtk-help"))))
35ec512c 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)))))))
4fb50b71 217
218
219;; Buttons
220
35ec512c 221(define-simple-dialog create-buttons (dialog "Buttons")
4fb50b71 222 (let ((table (make-instance 'table
35ec512c 223 :n-rows 3 :n-columns 3 :homogeneous nil
4fb50b71 224 :row-spacing 5 :column-spacing 5 :border-width 10
35ec512c 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
4fb50b71 231 (dotimes (column 3)
232 (dotimes (row 3)
35ec512c 233 (let ((button (nth (+ (* 3 row) column) buttons))
234 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
4fb50b71 235 (signal-connect button 'clicked
236 #'(lambda ()
237 (if (widget-visible-p button+1)
238 (widget-hide button+1)
239 (widget-show button+1))))
81f2aa93 240 (table-attach table button column (1+ column) row (1+ row)
241 :options '(:expand :fill)))))
35ec512c 242 (widget-show-all table)))
0d07716f 243
244
245;; Calenadar
246
35ec512c 247(define-simple-dialog create-calendar (dialog "Calendar")
248 (make-instance 'v-box
249 :parent dialog :border-width 10 :show-all t
250 :child (make-instance 'calendar)))
0d07716f 251
252
253;;; Check buttons
254
35ec512c 255(define-simple-dialog create-check-buttons (dialog "Check Buttons")
256 (make-instance 'v-box
257 :border-width 10 :spacing 10 :parent dialog :show-all t
258 :children (loop
259 for n from 1 to 3
260 collect (make-instance 'check-button
261 :label (format nil "Button~D" n)))))
0d07716f 262
263
264
265;;; Color selection
266
35ec512c 267(define-dialog create-color-selection (dialog "Color selection dialog"
268 'color-selection-dialog
269 :allow-grow nil :allow-shrink nil)
270 (with-slots (action-area colorsel) dialog
271;; This seg faults for some unknown reason
272;; (let ((button (make-instance 'check-button :label "Show Palette")))
273;; (dialog-add-action-widget dialog button
274;; #'(lambda ()
275;; (setf
276;; (color-selection-has-palette-p colorsel)
277;; (toggle-button-active-p button)))))
278
279 (container-add action-area
280 (create-check-button "Show Opacity"
281 #'(lambda (state)
282 (setf (color-selection-has-opacity-control-p colorsel) state))))
283
284 (container-add action-area
285 (create-check-button "Show Palette"
286 #'(lambda (state)
287 (setf (color-selection-has-palette-p colorsel) state))))
288
289 (signal-connect dialog :ok
290 #'(lambda ()
291 (let ((color (color-selection-current-color colorsel)))
292 (format t "Selected color: ~A~%" color)
293 (setf (color-selection-current-color colorsel) color)
294 (widget-hide dialog))))
0d07716f 295
35ec512c 296 (signal-connect dialog :cancel #'widget-destroy :object t)))
0d07716f 297
0d07716f 298
299;;; Cursors
300
301(defun clamp (n min-val max-val)
302 (declare (number n min-val max-val))
303 (max (min n max-val) min-val))
304
af5eb952 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)
8804934b 316 (widget-get-size-allocation drawing-area)
af5eb952 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))
0d07716f 349
af5eb952 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))
0d07716f 356
af5eb952 357 (signal-connect spinner 'changed
358 #'(lambda ()
359 (set-cursor spinner drawing-area label)))
0d07716f 360
af5eb952 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)))
0d07716f 379
380
381;;; Dialog
382
35ec512c 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))))))
0d07716f 402
35ec512c 403 (if (widget-visible-p dialog)
404 (widget-hide dialog)
405 (widget-show dialog))))
0d07716f 406
407
408;; Entry
409
35ec512c 410(define-simple-dialog create-entry (dialog "Entry")
411 (let ((main (make-instance 'v-box
412 :border-width 10 :spacing 10 :parent dialog)))
4fb50b71 413
35ec512c 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)
4fb50b71 419
e52cf822 420 (let ((combo (make-instance 'combo-box-entry
35ec512c 421 :parent main
e52cf822 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)))
35ec512c 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)))
0d07716f 449
0d07716f 450
36c95ad8 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
0d07716f 461
35ec512c 462;; File chooser dialog
0d07716f 463
35ec512c 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 ()
7c1f9a1e 468 (if (slot-boundp dialog 'filename)
469 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
470 (write-line "No files selected"))
35ec512c 471 (widget-destroy dialog))))
0d07716f 472
473
474
475;;; Handle box
476
35ec512c 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)))
0d07716f 483
35ec512c 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)))
0d07716f 488
35ec512c 489;; (toolbar-append-space toolbar)
0d07716f 490
35ec512c 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)))
0d07716f 495
35ec512c 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)))
0d07716f 500
35ec512c 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)))
0d07716f 505
35ec512c 506;; (toolbar-append-space toolbar)
0d07716f 507
35ec512c 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)))
0d07716f 512
35ec512c 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)))
0d07716f 517
35ec512c 518;; (toolbar-append-space toolbar)
0d07716f 519
35ec512c 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)))
0d07716f 524
35ec512c 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)))
0d07716f 529
35ec512c 530;; (toolbar-append-space toolbar)
0d07716f 531
35ec512c 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)))
0d07716f 536
35ec512c 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)))
0d07716f 541
35ec512c 542;; toolbar))
0d07716f 543
544
35ec512c 545;; (defun handle-box-child-signal (handle-box child action)
546;; (format t "~S: child ~S ~A~%" handle-box child action))
0d07716f 547
548
35ec512c 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)
0d07716f 556
e52cf822 557;; (container-add v-box (create-label "Above"))
35ec512c 558;; (container-add v-box (hseparator-new))
0d07716f 559
35ec512c 560;; (let ((hbox (hbox-new nil 10)))
561;; (container-add v-box hbox)
0d07716f 562
35ec512c 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")))
e52cf822 596;; (container-add handle-box2 (create-label "Foo!")))))
0d07716f 597
35ec512c 598;; (container-add v-box (hseparator-new))
e52cf822 599;; (container-add v-box (create-label "Below"))))
35ec512c 600
601;;; Image
0d07716f 602
35ec512c 603(define-toplevel create-image (window "Image")
604 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
0d07716f 605
606
607;;; Labels
608
35ec512c 609(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
4fb50b71 610 (flet ((create-label-in-frame (frame-label label-text &rest args)
611 (list
612 (make-instance 'frame
613 :label frame-label
35ec512c 614 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
4fb50b71 615 :fill nil :expand nil)))
35ec512c 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"
0d07716f 623"This is a Multi-line label.
624Second line
4fb50b71 625Third line")
35ec512c 626 :child (create-label-in-frame "Left Justified Label"
0d07716f 627"This is a Left-Justified
628Multi-line.
4fb50b71 629Third line"
35ec512c 630 :justify :left)
631 :child (create-label-in-frame "Right Justified Label"
0d07716f 632"This is a Right-Justified
633Multi-line.
4fb50b71 634Third line"
35ec512c 635 :justify :right))
636 :child (make-instance 'v-box
637 :spacing 5
638 :child (create-label-in-frame "Line wrapped label"
0d07716f 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.
4fb50b71 640 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
35ec512c 641 :wrap t)
642
643 :child (create-label-in-frame "Filled, wrapped label"
0d07716f 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.
4fb50b71 646 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
35ec512c 647 :justify :fill :wrap t)
648
649 :child (create-label-in-frame "Underlined label"
0d07716f 650"This label is underlined!
4fb50b71 651This one is underlined (こんにちは) in quite a funky fashion"
35ec512c 652 :justify :left
653 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
0d07716f 654
655
656;;; Layout
657
af5eb952 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)
35ec512c 677
678(define-toplevel create-layout (window "Layout" :default-width 200
679 :default-height 200)
4fb50b71 680 (let ((layout (make-instance 'layout
681 :parent (make-instance 'scrolled-window :parent window)
35ec512c 682 :width 1600 :height 128000 :events '(:exposure-mask)
af5eb952 683 :signal (list 'expose-event #'layout-expose :object t)
35ec512c 684 )))
4fb50b71 685
686 (with-slots (hadjustment vadjustment) layout
687 (setf
688 (adjustment-step-increment hadjustment) 10.0
689 (adjustment-step-increment vadjustment) 10.0))
0d07716f 690
691 (dotimes (i 16)
692 (dotimes (j 16)
35ec512c 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))))))
0d07716f 698
35ec512c 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)))))))
4fb50b71 706
0d07716f 707
708
709;;; List
710
549265c1 711(define-simple-dialog create-list (dialog "List" :default-height 400)
744118a7 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)))
0d07716f 718
549265c1 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))
744118a7 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))))
0d07716f 800
801
802;; Menus
803
804(defun create-menu (depth tearoff)
805 (unless (zerop depth)
35ec512c 806 (let ((menu (make-instance 'menu)))
0d07716f 807 (when tearoff
35ec512c 808 (let ((menu-item (make-instance 'tearoff-menu-item)))
809 (menu-shell-append menu menu-item)))
0d07716f 810 (let ((group nil))
811 (dotimes (i 5)
35ec512c 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))
0d07716f 818 (unless (zerop (mod depth 2))
35ec512c 819 (setf (check-menu-item-active-p menu-item) t))
820 (menu-shell-append menu menu-item)
0d07716f 821 (when (= i 3)
35ec512c 822 (setf (widget-sensitive-p menu-item) nil))
8804934b 823 (let ((submenu (create-menu (1- depth) t)))
824 (when submenu
825 (setf (menu-item-submenu menu-item) submenu))))))
4fb50b71 826 menu)))
0d07716f 827
828
35ec512c 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
e52cf822 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))))
0d07716f 856
e52cf822 857 (widget-show-all main)))
0d07716f 858
859
860;;; Notebook
861
8804934b 862(defun create-notebook-page (notebook page-num book-closed)
35ec512c 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)
8804934b 904 :child (make-instance 'image :pixbuf book-closed)
35ec512c 905 :child (make-instance 'label :label title)))
906 (menu-box (make-instance 'h-box
907 :show-all t
908 :child-args '(:expand nil)
8804934b 909 :child (make-instance 'image :pixbuf book-closed)
35ec512c 910 :child (make-instance 'label :label title))))
911
912 (widget-show-all page)
913 (notebook-append notebook page label-box menu-box))))
0d07716f 914
0d07716f 915
35ec512c 916(define-simple-dialog create-notebook (dialog "Notebook")
917 (let ((main (make-instance 'v-box :parent dialog)))
8804934b 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
35ec512c 921 :border-width 10 :tab-pos :top :parent main)))
8804934b 922 (flet ((set-image (page func pixbuf)
923 (setf
924 (image-pixbuf
925 (first (container-children (funcall func notebook page))))
926 pixbuf)))
35ec512c 927 (signal-connect notebook 'switch-page
928 #'(lambda (pointer page)
929 (declare (ignore pointer))
930 (unless (eq page (notebook-current-page-num notebook))
8804934b 931 (set-image page #'notebook-menu-label book-open)
932 (set-image page #'notebook-tab-label book-open)
35ec512c 933 (let ((curpage (notebook-current-page notebook)))
8804934b 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))
35ec512c 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))
e52cf822 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
8804934b 993 do (create-notebook-page notebook i book-closed))))))
e52cf822 994 :object t)))
35ec512c 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)))
0d07716f 1020
1021
1022;;; Panes
1023
1024(defun toggle-resize (child)
7c1f9a1e 1025 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
0d07716f 1026
1027(defun toggle-shrink (child)
7c1f9a1e 1028 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
0d07716f 1029
1030(defun create-pane-options (paned frame-label label1 label2)
7c1f9a1e 1031 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
81f2aa93 1032 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
35ec512c 1033 (let ((check-button (make-instance 'check-button :label "Resize")))
81f2aa93 1034 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 1038 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
7c1f9a1e 1039 (signal-connect check-button 'toggled
1040 #'toggle-shrink :object (paned-child1 paned)))
0d07716f 1041
81f2aa93 1042 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
7c1f9a1e 1043 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
81f2aa93 1044 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 1048 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
7c1f9a1e 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)))
0d07716f 1052
35ec512c 1053(define-toplevel create-panes (window "Panes")
1054 (let* ((hpaned (make-instance 'h-paned
4fb50b71 1055 :child1 (make-instance 'frame
35ec512c 1056 :width-request 60 :height-request 60
1057 :shadow-type :in
7c1f9a1e 1058 :child (make-instance 'button :label "Hi there"))
35ec512c 1059 :child2 (make-instance 'frame
1060 :width-request 80 :height-request 60
1061 :shadow-type :in)))
1062 (vpaned (make-instance 'v-paned
4fb50b71 1063 :border-width 5
1064 :child1 hpaned
1065 :child2 (make-instance 'frame
35ec512c 1066 :width-request 80 :height-request 60
1067 :shadow-type :in))))
4fb50b71 1068
35ec512c 1069 (make-instance 'v-box
4fb50b71 1070 :parent window
35ec512c 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"))))
0d07716f 1075
1076
0d07716f 1077;;; Progress bar
1078
8804934b 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))))))
0d07716f 1102
1103
1104;;; Radio buttons
1105
35ec512c 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
8179fd68 1109 :children (make-radio-group 'radio-button
1110 '((:label "button1") (:label "button2") (:label "button3"))
1111 nil)))
0d07716f 1112
1113
1114;;; Rangle controls
1115
35ec512c 1116(define-simple-dialog create-range-controls (dialog "Range controls")
0d07716f 1117 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
35ec512c 1118 (make-instance 'v-box
1119 :parent dialog :border-width 10 :spacing 10 :show-all t
1120 :child (make-instance 'h-scale
1121 :width-request 150 :adjustment adjustment :inverted t
1122 :update-policy :delayed :digits 1 :draw-value t)
1123 :child (make-instance 'h-scrollbar
1124 :adjustment adjustment :update-policy :continuous))))
0d07716f 1125
1126
1127;;; Reparent test
1128
35ec512c 1129(define-simple-dialog create-reparent (dialog "Reparent")
1130 (let ((main (make-instance 'h-box
1131 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
8804934b 1132 (label (make-instance 'label :label "Hello World")))
0d07716f 1133
35ec512c 1134 (flet ((create-frame (title)
1135 (let* ((frame (make-instance 'frame :label title :parent main))
1136 (box (make-instance 'v-box
1137 :spacing 5 :border-width 5 :parent frame))
1138 (button (make-instance 'button
1139 :label "switch" :parent (list box :expand nil))))
1140 (signal-connect button 'clicked
1141 #'(lambda ()
1142 (widget-reparent label box)))
1143 box)))
0d07716f 1144
35ec512c 1145 (box-pack-start (create-frame "Frame 1") label nil t 0)
1146 (create-frame "Frame 2"))
1147 (widget-show-all main)))
0d07716f 1148
1149
1150;;; Rulers
1151
35ec512c 1152(define-toplevel create-rulers (window "Rulers"
1153 :default-width 300 :default-height 300
1154;; :events '(:pointer-motion-mask
1155;; :pointer-motion-hint-mask)
1156 )
1157 (setf
1158 (widget-events window)
1159 '(:pointer-motion-mask :pointer-motion-hint-mask))
1160
81f2aa93 1161 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1162 (h-ruler (make-instance 'h-ruler
35ec512c 1163 :metric :centimeters :lower 100.0d0 :upper 0.0d0
81f2aa93 1164 :position 0.0d0 :max-size 20.0d0))
1165 (v-ruler (make-instance 'v-ruler
35ec512c 1166 :lower 5.0d0 :upper 15.0d0
1167 :position 0.0d0 :max-size 20.0d0)))
81f2aa93 1168 (signal-connect window 'motion-notify-event
1169 #'(lambda (event)
1170 (widget-event h-ruler event)
1171 (widget-event v-ruler event)))
1172 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1173 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
0d07716f 1174
1175
1176;;; Scrolled window
1177
35ec512c 1178(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1179 :default-width 300
1180 :default-height 300)
4fb50b71 1181 (let* ((scrolled-window
1182 (make-instance 'scrolled-window
35ec512c 1183 :parent dialog :border-width 10
1184 :vscrollbar-policy :automatic
4fb50b71 1185 :hscrollbar-policy :automatic))
1186 (table
1187 (make-instance 'table
35ec512c 1188 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
4fb50b71 1189 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1190 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
0d07716f 1191
0d07716f 1192 (scrolled-window-add-with-viewport scrolled-window table)
0d07716f 1193 (dotimes (i 20)
1194 (dotimes (j 20)
1195 (let ((button
35ec512c 1196 (make-instance 'toggle-button
1197 :label (format nil "button (~D,~D)~%" i j))))
1198 (table-attach table button i (1+ i) j (1+ j)))))
1199 (widget-show-all scrolled-window)))
0d07716f 1200
1201
81f2aa93 1202;;; Size group
1203
1204(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1205 (let ((size-group (make-instance 'size-group)))
1206 (flet ((create-frame (label rows)
1207 (let ((table (make-instance 'table
1208 :n-rows (length rows) :n-columns 2 :homogeneous nil
1209 :row-spacing 5 :column-spacing 10 :border-width 5)))
1210 (loop
1211 for row in rows
1212 for i from 0
1213 do (table-attach table
1214 (create-label (first row) :xalign 0 :yalign 1)
1215 0 1 i (1+ i) :x-options '(:expand :fill))
1216 (let ((combo (make-instance 'combo-box
1217 :content (rest row) :active 0)))
1218 (size-group-add-widget size-group combo)
1219 (table-attach table combo 1 2 i (1+ i))))
1220 (make-instance 'frame :label label :child table))))
1221
1222 (make-instance 'v-box
1223 :parent dialog :border-width 5 :spacing 5 :show-all t
1224 :child (create-frame "Color Options"
1225 '(("Foreground" "Red" "Green" "Blue")
1226 ("Background" "Red" "Green" "Blue")))
1227 :child (create-frame "Line Options"
1228 '(("Dashing" "Solid" "Dashed" "Dotted")
1229 ("Line ends" "Square" "Round" "Arrow")))
1230 :child (create-check-button "Enable grouping"
1231 #'(lambda (active)
1232 (setf
1233 (size-group-mode size-group)
1234 (if active :horizontal :none)))
1235 t)))))
1236
1237
0d07716f 1238;;; Shapes
1239
35ec512c 1240;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1241;; (let* ((window
1242;; (make-instance 'window
1243;; :type type :x x :y y
1244;; :events '(:button-motion :pointer-motion-hint :button-press)))
1245;; (fixed
1246;; (make-instance 'fixed
1247;; :parent window :width 100 :height 100)))
4fb50b71 1248
35ec512c 1249;; (widget-realize window)
1250;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1251;; (let ((pixmap (pixmap-new source mask))
1252;; (x-offset 0)
1253;; (y-offset 0))
1254;; (declare (fixnum x-offset y-offset))
1255;; (fixed-put fixed pixmap px py)
1256;; (widget-shape-combine-mask window mask px py)
4fb50b71 1257
35ec512c 1258;; (signal-connect window 'button-press-event
1259;; #'(lambda (event)
1260;; (when (typep event 'gdk:button-press-event)
1261;; (setq x-offset (truncate (gdk:event-x event)))
1262;; (setq y-offset (truncate (gdk:event-y event)))
1263;; (grab-add window)
1264;; (gdk:pointer-grab
1265;; (widget-window window) t
1266;; '(:button-release :button-motion :pointer-motion-hint)
1267;; nil nil 0))
1268;; t))
1269
1270;; (signal-connect window 'button-release-event
1271;; #'(lambda (event)
1272;; (declare (ignore event))
1273;; (grab-remove window)
1274;; (gdk:pointer-ungrab 0)
1275;; t))
0d07716f 1276
35ec512c 1277;; (signal-connect window 'motion-notify-event
1278;; #'(lambda (event)
1279;; (declare (ignore event))
1280;; (multiple-value-bind (win xp yp mask)
1281;; (gdk:window-get-pointer root-window)
1282;; (declare (ignore mask win) (fixnum xp yp))
1283;; (widget-set-uposition
1284;; window :x (- xp x-offset) :y (- yp y-offset)))
1285;; t))
1286;; (signal-connect window 'destroy destroy)))
0d07716f 1287
35ec512c 1288;; (widget-show-all window)
1289;; window))
1290
1291
1292;; (let ((modeller nil)
1293;; (sheets nil)
1294;; (rings nil))
1295;; (defun create-shapes ()
1296;; (let ((root-window (gdk:get-root-window)))
1297;; (if (not modeller)
1298;; (setq
1299;; modeller
1300;; (shape-create-icon
1301;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1302;; #'(lambda () (widget-destroyed modeller))))
1303;; (widget-destroy modeller))
1304
1305;; (if (not sheets)
1306;; (setq
1307;; sheets
1308;; (shape-create-icon
1309;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1310;; #'(lambda () (widget-destroyed sheets))))
1311;; (widget-destroy sheets))
1312
1313;; (if (not rings)
1314;; (setq
1315;; rings
1316;; (shape-create-icon
1317;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1318;; #'(lambda () (widget-destroyed rings))))
1319;; (widget-destroy rings)))))
0d07716f 1320
1321
1322
1323;;; Spin buttons
1324
35ec512c 1325(define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1326 (let ((main (make-instance 'v-box
1327 :spacing 5 :border-width 10 :parent dialog)))
1328
1329 (flet ((create-date-spinner (label adjustment shadow-type)
1330 (declare (ignore shadow-type))
1331 (make-instance 'v-box
1332 :child-args '(:expand nil)
1333 :child (make-instance 'label
1334 :label label :xalign 0.0 :yalign 0.5)
1335 :child (make-instance 'spin-button
1336 :adjustment adjustment :wrap t))))
1337 (make-instance 'frame
1338 :label "Not accelerated" :parent main
1339 :child (make-instance 'h-box
1340 :border-width 10
1341 :child-args '(:padding 5)
1342 :child (create-date-spinner "Day : "
1343 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1344 :child (create-date-spinner "Month : "
5ff67599 1345 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
35ec512c 1346 :child (create-date-spinner "Year : "
1347 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1348
1349 (let ((spinner1 (make-instance 'spin-button
1350 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1351 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1352 (spinner2 (make-instance 'spin-button
1353 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1354 :climb-rate 1.0 :wrap t))
1355 (value-label (make-instance 'label :label "0")))
1356 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1357 #'(lambda ()
1358 (setf
1359 (spin-button-digits spinner1)
1360 (floor (spin-button-value spinner2)))))
1361
1362 (make-instance 'frame
1363 :label "Accelerated" :parent main
1364 :child (make-instance 'v-box
1365 :border-width 5
1366 :child (list
1367 (make-instance 'h-box
1368 :child-args '(:padding 5)
1369 :child (make-instance 'v-box
1370 :child (make-instance 'label
1371 :label "Value :"
1372 :xalign 0.0 :yalign 0.5)
1373 :child spinner1)
1374 :child (make-instance 'v-box
1375 :child (make-instance 'label
1376 :label "Digits :"
1377 :xalign 0.0 :yalign 0.5)
1378 :child spinner2))
1379 :expand nil :padding 5)
1380 :child (make-instance 'check-button
1381 :label "Snap to 0.5-ticks" :active t
1382 :signal (list 'clicked
1383 #'(lambda (button)
1384 (setf
1385 (spin-button-snap-to-ticks-p spinner1)
1386 (toggle-button-active-p button)))
1387 :object t))
1388 :child (make-instance 'check-button
1389 :label "Numeric only input mode" :active t
1390 :signal (list 'clicked
1391 #'(lambda (button)
1392 (setf
1393 (spin-button-numeric-p spinner1)
1394 (toggle-button-active-p button)))
1395 :object t))
1396 :child value-label
1397 :child (list
1398 (make-instance 'h-box
1399 :child-args '(:padding 5)
1400 :child (make-instance 'button
1401 :label "Value as Int"
1402 :signal (list 'clicked
1403 #'(lambda ()
1404 (setf
1405 (label-label value-label)
1406 (format nil "~D"
1407 (spin-button-value-as-int
1408 spinner1))))))
1409 :child (make-instance 'button
1410 :label "Value as Float"
1411 :signal (list 'clicked
1412 #'(lambda ()
1413 (setf
1414 (label-label value-label)
1415 (format nil
1416 (format nil "~~,~DF"
1417 (spin-button-digits spinner1))
1418 (spin-button-value spinner1)))))))
1419 :padding 5 :expand nil))))
1420 (widget-show-all main)))
0d07716f 1421
35ec512c 1422
5ff67599 1423;;; Statusbar
0d07716f 1424
5ff67599 1425(define-toplevel create-statusbar (window "Statusbar")
1426 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1427 (close-button (create-button '("close" :can-default t)
1428 #'widget-destroy :object window))
1429 (counter 0))
1430
1431 (signal-connect statusbar 'text-popped
1432 #'(lambda (context-id text)
1433 (declare (ignore context-id))
1434 (format nil "Popped: ~A~%" text)))
1435
1436 (make-instance 'v-box
1437 :parent window
1438 :child (make-instance 'v-box
1439 :border-width 10 :spacing 10
1440 :child (create-button "push something"
1441 #'(lambda ()
1442 (statusbar-push statusbar 1
1443 (format nil "something ~D" (incf counter)))))
1444 :child (create-button "pop"
1445 #'(lambda ()
1446 (statusbar-pop statusbar 1)))
1447 :child (create-button "steal #4"
1448 #'(lambda ()
1449 (statusbar-remove statusbar 1 4)))
1450 :child (create-button "dump stack")
1451 :child (create-button "test contexts"))
1452 :child (list (make-instance 'h-separator) :expand nil)
1453 :child (list
1454 (make-instance 'v-box :border-width 10 :child close-button)
1455 :expand nil)
1456 :child (list statusbar :expand nil))
1457
1458 (widget-grab-focus close-button)))
0d07716f 1459
1460
1461;;; Idle test
1462
e025589b 1463(define-simple-dialog create-idle-test (dialog "Idle Test")
1464 (let ((label (make-instance 'label
1465 :label "count: 0" :xpad 10 :ypad 10))
1466 (idle nil)
1467 (count 0))
1468 (signal-connect dialog 'destroy
1469 #'(lambda () (when idle (idle-remove idle))))
0d07716f 1470
e025589b 1471 (make-instance 'v-box
1472 :parent dialog :border-width 10 :spacing 10 :show-all t
1473 :child label
1474 :child (make-instance 'frame
1475 :label "Label Container" :border-width 5
1476 :child(make-instance 'v-box
8179fd68 1477 :children (make-radio-group 'radio-button
1478 '((:label "Resize-Parent" :value :parent :active t)
1479 (:label "Resize-Queue" :value :queue)
1480 (:label "Resize-Immediate" :value :immediate))
e025589b 1481 #'(lambda (mode)
1482 (setf
1483 (container-resize-mode (dialog-action-area dialog)) mode))))))
1484
1485 (dialog-add-button dialog "Start"
1486 #'(lambda ()
1487 (unless idle
1488 (setq idle
1489 (idle-add
1490 #'(lambda ()
1491 (incf count)
1492 (setf (label-label label) (format nil "count: ~D" count))
1493 t))))))
0d07716f 1494
e025589b 1495 (dialog-add-button dialog "Stop"
1496 #'(lambda ()
1497 (when idle
1498 (idle-remove idle)
1499 (setq idle nil))))))
0d07716f 1500
1501
1502
1503;;; Timeout test
1504
e025589b 1505(define-simple-dialog create-timeout-test (dialog "Timeout Test")
1506 (let ((label (make-instance 'label
1507 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1508 (timer nil)
1509 (count 0))
1510 (signal-connect dialog 'destroy
1511 #'(lambda () (when timer (timeout-remove timer))))
1512
1513 (dialog-add-button dialog "Start"
1514 #'(lambda ()
1515 (unless timer
1516 (setq timer
1517 (timeout-add 100
1518 #'(lambda ()
1519 (incf count)
1520 (setf (label-label label) (format nil "count: ~D" count))
1521 t))))))
1522
1523 (dialog-add-button dialog "Stop"
1524 #'(lambda ()
1525 (when timer
1526 (timeout-remove timer)
1527 (setq timer nil))))))
7932cfab 1528
1529
1530;;; Text
1531
1532(define-simple-dialog create-text (dialog "Text" :default-width 400
1533 :default-height 400)
81f2aa93 1534 (let* ((text-view (make-instance 'text-view
1535 :border-width 10 :visible t :wrap-mode :word))
1536 (buffer (text-view-buffer text-view))
1537 (active-tags ()))
1538
1539 (text-buffer-create-tag buffer "Bold" :weight :bold)
1540 (text-buffer-create-tag buffer "Italic" :style :italic)
1541 (text-buffer-create-tag buffer "Underline" :underline :single)
1542
1543 (flet ((create-toggle-callback (tag-name)
1544 (let ((tag (text-tag-table-lookup
1545 (text-buffer-tag-table buffer) tag-name)))
1546 #'(lambda (active)
1547 (unless (eq (and (find tag active-tags) t) active)
1548 ;; user activated
1549 (if active
1550 (push tag active-tags)
1551 (setq active-tags (delete tag active-tags)))
1552 (multiple-value-bind (start end)
1553 (text-buffer-get-selection-bounds buffer)
1554 (if active
1555 (text-buffer-apply-tag buffer tag start end)
1556 (text-buffer-remove-tag buffer tag start end))))))))
1557
1558 (let* ((actions
1559 (make-instance 'action-group
1560 :action (create-toggle-action
1561 "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1562 (create-toggle-callback "Bold"))
1563 :action (create-toggle-action
1564 "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1565 (create-toggle-callback "Italic"))
1566 :action (create-toggle-action
1567 "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1568 (create-toggle-callback "Underline"))))
1569 (ui (make-instance 'ui-manager)))
1570
1571 (ui-manager-insert-action-group ui actions)
1572 (ui-manager-add-ui ui
1573 '((:toolbar "ToolBar"
1574 (:toolitem "Bold")
1575 (:toolitem "Italic")
1576 (:toolitem "Underline"))))
1577
1578 ;; Callback to activate/deactivate toolbar buttons when cursor
1579 ;; is moved
1580 (signal-connect buffer 'mark-set
1581 #'(lambda (location mark)
1582 (declare (ignore mark))
1583 (text-tag-table-foreach (text-buffer-tag-table buffer)
1584 #'(lambda (tag)
1585 (let ((active
1586 (or
1587 (and
1588 (text-iter-has-tag-p location tag)
1589 (not (text-iter-begins-tag-p location tag)))
1590 (text-iter-ends-tag-p location tag))))
1591 (unless (eq active (and (find tag active-tags) t))
1592 (if active
1593 (push tag active-tags)
1594 (setq active-tags (delete tag active-tags)))
1595 (setf
1596 (toggle-action-active-p
1597 (action-group-get-action actions (text-tag-name tag)))
1598 active)))))))
1599
1600 ;; Callback to apply active tags when a character is inserted
1601 (signal-connect buffer 'insert-text
1602 #'(lambda (iter &rest args)
1603 (declare (ignore args))
1604 (let ((before (text-buffer-get-iter-at-offset buffer
1605 (1- (text-iter-offset iter)))))
1606 (loop
1607 for tag in active-tags
1608 do (text-buffer-apply-tag buffer tag before iter))))
1609 :after t)
1610
1611 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1612 (container-add dialog text-view)))))
1613
0d07716f 1614
0d07716f 1615;;; Toggle buttons
1616
35ec512c 1617(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1618 (make-instance 'v-box
1619 :border-width 10 :spacing 10 :parent dialog :show-all t
1620 :children (loop
1621 for n from 1 to 3
1622 collect (make-instance 'toggle-button
1623 :label (format nil "Button~D" (1+ n))))))
0d07716f 1624
1625
1626
1627;;; Toolbar test
1628
35ec512c 1629(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
8179fd68 1630 (make-instance 'toolbar
1631 :show-tooltips t :show-arrow nil :parent window
1632
1633 ;; Insert a stock item
1634 :child (make-instance 'tool-button
1635 :stock "gtk-quit"
1636 :tip-text "Destroy toolbar"
1637 :tip-private "Toolbar/Quit"
1638 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1639
1640 :child (make-instance 'separator-tool-item)
1641
1642 :child (make-instance 'tool-button
1643 :label "Horizontal" :stock "gtk-go-forward"
1644 :tip-text "Horizontal toolbar layout"
1645 :tip-private "Toolbar/Horizontal"
1646 :signal (list 'clicked
1647 #'(lambda (toolbar)
1648 (setf (toolbar-orientation toolbar) :horizontal))
1649 :object :parent))
1650
1651 :child (make-instance 'tool-button
1652 :label "Vertical" :stock "gtk-go-down"
1653 :tip-text "Vertical toolbar layout"
1654 :tip-private "Toolbar/Vertical"
1655 :signal (list 'clicked
1656 #'(lambda (toolbar)
1657 (setf (toolbar-orientation toolbar) :vertical))
1658 :object :parent))
1659
1660 :child (make-instance 'separator-tool-item)
1661
1662 :children (make-radio-group 'radio-tool-button
1663 '((:label "Icons" :stock "gtk-justify-left"
1664 :tip-text "Only show toolbar icons"
1665 :tip-private "Toolbar/IconsOnly"
1666 :value :icons)
1667 (:label "Both" :stock "gtk-justify-center"
1668 :tip-text "Show toolbar icons and text"
1669 :tip-private "Toolbar/Both"
1670 :value :both :active t)
1671 (:label "Text" :stock "gtk-justify-right"
1672 :tip-text "Show toolbar text"
1673 :tip-private "Toolbar/TextOnly"
1674 :value :text))
1675 (list
1676 #'(lambda (toolbar style)
1677 (setf (toolbar-style toolbar) style))
1678 :object :parent))
1679
1680 :child (make-instance 'separator-tool-item)
1681
1682 :child (make-instance 'tool-item
1683 :child (make-instance 'entry)
1684 :tip-text "This is an unusable GtkEntry"
1685 :tip-private "Hey don't click me!")
1686
1687 :child (make-instance 'separator-tool-item)
1688
1689 :child (make-instance 'tool-button
1690 :label "Enable" :stock "gtk-add"
1691 :tip-text "Enable tooltips"
1692 :tip-private "Toolbar/EnableTooltips"
1693 :signal (list 'clicked
1694 #'(lambda (toolbar)
1695 (setf (toolbar-show-tooltips-p toolbar) t))
1696 :object :parent))
1697
1698 :child (make-instance 'tool-button
1699 :label "Disable" :stock "gtk-remove"
1700 :tip-text "Disable tooltips"
1701 :tip-private "Toolbar/DisableTooltips"
1702 :signal (list 'clicked
1703 #'(lambda (toolbar)
1704 (setf (toolbar-show-tooltips-p toolbar) nil))
1705 :object :parent))
1706
1707;; :child (make-instance 'separator-tool-item)
1708
1709;; :child (make-instance 'tool-button
1710;; :label "GTK" :icon #p"clg:examples;gtk.png"
1711;; :tip-text "GTK+ Logo"
1712;; :tip-private "Toolbar/GTK+")
1713 ))
0d07716f 1714
1715
1716
1717;;; Tooltips test
1718
e025589b 1719(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1720 (let ((tooltips (make-instance 'tooltips)))
1721 (flet ((create-button (label tip-text tip-private)
1722 (let ((button (make-instance 'toggle-button :label label)))
1723 (tooltips-set-tip tooltips button tip-text tip-private)
1724 button)))
1725 (make-instance 'v-box
1726 :parent dialog :border-width 10 :spacing 10 :show-all t
1727 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
7c1f9a1e 1728 :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")))))
7932cfab 1729
1730
1731;;; UI Manager
1732
1733(defvar *ui-description*
1734 '((:menubar "MenuBar"
1735 (:menu "FileMenu"
1736 (:menuitem "New")
1737 (:menuitem "Open")
1738 (:menuitem "Save")
1739 (:menuitem "SaveAs")
1740 :separator
1741 (:menuitem "Quit"))
1742 (:menu "PreferencesMenu"
1743 (:menu "ColorMenu"
1744 (:menuitem "Red")
1745 (:menuitem "Green")
1746 (:menuitem "Blue"))
1747 (:menu "ShapeMenu"
1748 (:menuitem "Square")
1749 (:menuitem "Rectangle")
1750 (:menuitem "Oval"))
1751 (:menuitem "Bold"))
1752 (:menu "HelpMenu"
1753 (:menuitem "About")))
1754 (:toolbar "ToolBar"
1755 (:toolitem "Open")
1756 (:toolitem "Quit")
1757 (:separator "Sep1")
1758 (:toolitem "Logo"))))
1759
81f2aa93 1760(define-toplevel create-ui-manager (window "UI Manager")
7932cfab 1761 (let ((actions
1762 (make-instance 'action-group
1763 :name "Actions"
1764 :action (create-action "FileMenu" nil "_File")
1765 :action (create-action "PreferencesMenu" nil "_Preferences")
1766 :action (create-action "ColorMenu" nil "_Color")
1767 :action (create-action "ShapeMenu" nil "_Shape")
1768 :action (create-action "HelpMenu" nil "_Help")
1769 :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
81f2aa93 1770 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
7932cfab 1771 :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1772 :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
81f2aa93 1773 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
7932cfab 1774 :action (create-action "About" nil "_About" "<control>A" "About")
1775 :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1776 :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1777 :actions (create-radio-actions
1778 '(("Red" nil "_Red" "<control>R" "Blood")
1779 ("Green" nil "_Green" "<control>G" "Grass")
1780 ("Blue" nil "_Blue" "<control>B" "Sky"))
1781 "Green")
1782 :actions (create-radio-actions
1783 '(("Square" nil "_Square" "<control>S" "Square")
1784 ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1785 ("Oval" nil "_Oval" "<control>O" "Egg")))))
1786 (ui (make-instance 'ui-manager)))
1787
1788 (ui-manager-insert-action-group ui actions)
1789 (ui-manager-add-ui ui *ui-description*)
1790
81f2aa93 1791 (window-add-accel-group window (ui-manager-accel-group ui))
7932cfab 1792
1793 (make-instance 'v-box
81f2aa93 1794 :parent window :show-all t
7932cfab 1795 :child (list
1796 (ui-manager-get-widget ui "/MenuBar")
1797 :expand nil :fill nil)
1798 :child (list
1799 (ui-manager-get-widget ui "/ToolBar")
1800 :expand nil :fill nil)
1801 :child (make-instance 'label
1802 :label "Type <alt> to start"
1803 :xalign 0.5 :yalign 0.5
1804 :width-request 200 :height-request 200))))
0d07716f 1805
1806
1807
0d07716f 1808;;; Main window
1809
1810(defun create-main-window ()
35ec512c 1811;; (rc-parse "clg:examples;testgtkrc2")
1812;; (rc-parse "clg:examples;testgtkrc")
4fb50b71 1813
1814 (let* ((button-specs
0d07716f 1815 '(("button box" create-button-box)
35ec512c 1816 ("buttons" create-buttons)
1817 ("calendar" create-calendar)
1818 ("check buttons" create-check-buttons)
35ec512c 1819 ("color selection" create-color-selection)
af5eb952 1820 ("cursors" create-cursors)
35ec512c 1821 ("dialog" create-dialog)
1822;; ; ("dnd")
1823 ("entry" create-entry)
1824;; ("event watcher")
36c95ad8 1825 ("enxpander" create-expander)
35ec512c 1826 ("file chooser" create-file-chooser)
1827;; ("font selection")
1828;; ("handle box" create-handle-box)
1829 ("image" create-image)
35ec512c 1830 ("labels" create-labels)
1831 ("layout" create-layout)
549265c1 1832 ("list" create-list)
0d07716f 1833 ("menus" create-menus)
35ec512c 1834;; ("modal window")
1835 ("notebook" create-notebook)
1836 ("panes" create-panes)
8804934b 1837 ("progress bar" create-progress-bar)
35ec512c 1838 ("radio buttons" create-radio-buttons)
1839 ("range controls" create-range-controls)
1840;; ("rc file")
1841 ("reparent" create-reparent)
1842 ("rulers" create-rulers)
1843;; ("saved position")
1844 ("scrolled windows" create-scrolled-windows)
81f2aa93 1845 ("size group" create-size-group)
35ec512c 1846;; ("shapes" create-shapes)
1847 ("spinbutton" create-spins)
5ff67599 1848 ("statusbar" create-statusbar)
e025589b 1849 ("test idle" create-idle-test)
35ec512c 1850;; ("test mainloop")
1851;; ("test scrolling")
1852;; ("test selection")
e025589b 1853 ("test timeout" create-timeout-test)
7932cfab 1854 ("text" create-text)
35ec512c 1855 ("toggle buttons" create-toggle-buttons)
1856 ("toolbar" create-toolbar)
e025589b 1857 ("tooltips" create-tooltips)
35ec512c 1858;; ("tree" #|create-tree|#)
7932cfab 1859 ("UI manager" create-ui-manager)
35ec512c 1860))
1861 (main-window (make-instance 'window
1862 :title "testgtk.lisp" :name "main_window"
1863 :default-width 200 :default-height 400
1864 :allow-grow t :allow-shrink nil))
1865 (scrolled-window (make-instance 'scrolled-window
1866 :hscrollbar-policy :automatic
1867 :vscrollbar-policy :automatic
1868 :border-width 10))
1869 (close-button (make-instance 'button
1870 :label "close" :can-default t
1871 :signal (list 'clicked #'widget-destroy
1872 :object main-window))))
0d07716f 1873
8804934b 1874 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1875 (setf
1876 (window-icon main-window)
1877 (gdk:pixbuf-add-alpha icon t 254 254 252)))
7c1f9a1e 1878
0d07716f 1879 ;; Main box
35ec512c 1880 (make-instance 'v-box
0d07716f 1881 :parent main-window
35ec512c 1882 :child-args '(:expand nil)
1883 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1884 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1885 :child (list scrolled-window :expand t)
1886 :child (make-instance 'h-separator)
1887 :child (make-instance 'v-box
1888 :homogeneous nil :spacing 10 :border-width 10
1889 :child close-button))
1890
1891 (let ((content-box
1892 (make-instance 'v-box
1893 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1894 :children (mapcar #'(lambda (spec)
1895 (apply #'create-button spec))
1896 button-specs))))
1897 (scrolled-window-add-with-viewport scrolled-window content-box))
0d07716f 1898
35ec512c 1899 (widget-grab-focus close-button)
0d07716f 1900 (widget-show-all main-window)
1901 main-window))
1902
35ec512c 1903(clg-init)
1904(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).