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