~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
0d07716f 1;; Common Lisp bindings for GTK+ v2.0
2;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.no>
3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
7c1f9a1e 18;; $Id: testgtk.lisp,v 1.13 2004/12/26 12:01:10 espen Exp $
0d07716f 19
20
35ec512c 21;;; Some of the code in this file are really outdatet, but it is
22;;; still the most complete example of how to use the library
0d07716f 23
35ec512c 24
25;(use-package "GTK")
26(in-package "GTK")
27
28(defmacro define-toplevel (name (window title &rest initargs) &body body)
29 `(let ((,window nil))
0d07716f 30 (defun ,name ()
35ec512c 31 (unless ,window
32 (setq ,window (apply #'make-instance 'window :title ,title ',initargs))
33 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
0d07716f 34 ,@body)
35
35ec512c 36 (if (not (widget-visible-p ,window))
37 (widget-show-all ,window)
38 (widget-hide ,window)))))
39
0d07716f 40
35ec512c 41(defmacro define-dialog (name (dialog title &optional (class 'dialog)
42 &rest initargs)
43 &body body)
44 `(let ((,dialog nil))
0d07716f 45 (defun ,name ()
35ec512c 46 (unless ,dialog
47 (setq ,dialog (apply #'make-instance ,class :title ,title ',initargs))
48 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
49 ,@body)
0d07716f 50
35ec512c 51 (if (not (widget-visible-p ,dialog))
52 (widget-show ,dialog)
53 (widget-hide ,dialog)))))
0d07716f 54
55
35ec512c 56(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
57 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
e025589b 58 ,@body
59 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
0d07716f 60
61
0d07716f 62
63;;; Pixmaps used in some of the tests
64
65(defvar gtk-mini-xpm
4fb50b71 66 #("15 20 17 1"
0d07716f 67 " c None"
68 ". c #14121F"
69 "+ c #278828"
70 "@ c #9B3334"
71 "# c #284C72"
72 "$ c #24692A"
73 "% c #69282E"
74 "& c #37C539"
75 "* c #1D2F4D"
76 "= c #6D7076"
77 "- c #7D8482"
78 "; c #E24A49"
79 "> c #515357"
80 ", c #9B9C9B"
81 "' c #2FA232"
82 ") c #3CE23D"
83 "! c #3B6CCB"
84 " "
85 " ***> "
86 " >.*!!!* "
87 " ***....#*= "
88 " *!*.!!!**!!# "
89 " .!!#*!#*!!!!# "
90 " @%#!.##.*!!$& "
91 " @;%*!*.#!#')) "
92 " @;;@%!!*$&)'' "
93 " @%.%@%$'&)$+' "
94 " @;...@$'*'*)+ "
95 " @;%..@$+*.')$ "
96 " @;%%;;$+..$)# "
97 " @;%%;@$$$'.$# "
98 " %;@@;;$$+))&* "
99 " %;;;@+$&)&* "
100 " %;;@'))+> "
101 " %;@'&# "
102 " >%$$ "
103 " >= "))
104
105(defvar book-closed-xpm
4fb50b71 106 #("16 16 6 1"
0d07716f 107 " c None s None"
108 ". c black"
109 "X c red"
110 "o c yellow"
111 "O c #808080"
112 "# c white"
113 " "
114 " .. "
115 " ..XX. "
116 " ..XXXXX. "
117 " ..XXXXXXXX. "
118 ".ooXXXXXXXXX. "
119 "..ooXXXXXXXXX. "
120 ".X.ooXXXXXXXXX. "
121 ".XX.ooXXXXXX.. "
122 " .XX.ooXXX..#O "
123 " .XX.oo..##OO. "
124 " .XX..##OO.. "
125 " .X.#OO.. "
126 " ..O.. "
127 " .. "
128 " "))
129
130(defvar mini-page-xpm
4fb50b71 131 #("16 16 4 1"
0d07716f 132 " c None s None"
133 ". c black"
134 "X c white"
135 "o c #808080"
136 " "
137 " ....... "
138 " .XXXXX.. "
139 " .XoooX.X. "
140 " .XXXXX.... "
141 " .XooooXoo.o "
142 " .XXXXXXXX.o "
143 " .XooooooX.o "
144 " .XXXXXXXX.o "
145 " .XooooooX.o "
146 " .XXXXXXXX.o "
147 " .XooooooX.o "
148 " .XXXXXXXX.o "
149 " ..........o "
150 " oooooooooo "
151 " "))
152
153(defvar book-open-xpm
4fb50b71 154 #("16 16 4 1"
0d07716f 155 " c None s None"
156 ". c black"
157 "X c #808080"
158 "o c white"
159 " "
160 " .. "
161 " .Xo. ... "
162 " .Xoo. ..oo. "
163 " .Xooo.Xooo... "
164 " .Xooo.oooo.X. "
165 " .Xooo.Xooo.X. "
166 " .Xooo.oooo.X. "
167 " .Xooo.Xooo.X. "
168 " .Xooo.oooo.X. "
169 " .Xoo.Xoo..X. "
170 " .Xo.o..ooX. "
171 " .X..XXXXX. "
172 " ..X....... "
173 " .. "
174 " "))
175
176
177
178;;; Button box
179
4fb50b71 180(defun create-bbox-in-frame (class frame-label spacing width height layout)
35ec512c 181 (declare (ignore width height))
182 (make-instance 'frame
183 :label frame-label
184 :child (make-instance class
185 :border-width 5 :layout-style layout :spacing spacing
186; :child-min-width width :child-min-height height
7932cfab 187 :child (make-instance 'button :label "gtk-ok" :use-stock t)
188 :child (make-instance 'button :label "gtk-cancel" :use-stock t)
189 :child (make-instance 'button :label "gtk-help" :use-stock t))))
35ec512c 190
191(define-toplevel create-button-box (window "Button Boxes")
192 (make-instance 'v-box
193 :parent window :border-width 10 :spacing 10 :show-all t
194 :child (make-instance 'frame
195 :label "Horizontal Button Boxes"
196 :child (make-instance 'v-box
197 :border-width 10 :spacing 10
198 :children (mapcar
199 #'(lambda (args)
200 (apply #'create-bbox-in-frame
201 'h-button-box args))
202 '(("Spread" 40 85 20 :spread)
203 ("Edge" 40 85 20 :edge)
204 ("Start" 40 85 20 :start)
205 ("End" 40 85 20 :end)))))
206 :child (make-instance 'frame
207 :label "Vertical Button Boxes"
208 :child (make-instance 'h-box
209 :border-width 10 :spacing 10
210 :children (mapcar
211 #'(lambda (args)
212 (apply #'create-bbox-in-frame
213 'v-button-box args))
214 '(("Spread" 30 85 20 :spread)
215 ("Edge" 30 85 20 :edge)
216 ("Start" 30 85 20 :start)
217 ("End" 30 85 20 :end)))))))
4fb50b71 218
219
220;; Buttons
221
35ec512c 222(define-simple-dialog create-buttons (dialog "Buttons")
4fb50b71 223 (let ((table (make-instance 'table
35ec512c 224 :n-rows 3 :n-columns 3 :homogeneous nil
4fb50b71 225 :row-spacing 5 :column-spacing 5 :border-width 10
35ec512c 226 :parent dialog))
227 (buttons (loop
228 for n from 1 to 10
229 collect (make-instance 'button
230 :label (format nil "button~D" (1+ n))))))
231
4fb50b71 232 (dotimes (column 3)
233 (dotimes (row 3)
35ec512c 234 (let ((button (nth (+ (* 3 row) column) buttons))
235 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
4fb50b71 236 (signal-connect button 'clicked
237 #'(lambda ()
238 (if (widget-visible-p button+1)
239 (widget-hide button+1)
240 (widget-show button+1))))
81f2aa93 241 (table-attach table button column (1+ column) row (1+ row)
242 :options '(:expand :fill)))))
35ec512c 243 (widget-show-all table)))
0d07716f 244
245
246;; Calenadar
247
35ec512c 248(define-simple-dialog create-calendar (dialog "Calendar")
249 (make-instance 'v-box
250 :parent dialog :border-width 10 :show-all t
251 :child (make-instance 'calendar)))
0d07716f 252
253
254;;; Check buttons
255
35ec512c 256(define-simple-dialog create-check-buttons (dialog "Check Buttons")
257 (make-instance 'v-box
258 :border-width 10 :spacing 10 :parent dialog :show-all t
259 :children (loop
260 for n from 1 to 3
261 collect (make-instance 'check-button
262 :label (format nil "Button~D" n)))))
0d07716f 263
264
265
266;;; Color selection
267
35ec512c 268(define-dialog create-color-selection (dialog "Color selection dialog"
269 'color-selection-dialog
270 :allow-grow nil :allow-shrink nil)
271 (with-slots (action-area colorsel) dialog
272;; This seg faults for some unknown reason
273;; (let ((button (make-instance 'check-button :label "Show Palette")))
274;; (dialog-add-action-widget dialog button
275;; #'(lambda ()
276;; (setf
277;; (color-selection-has-palette-p colorsel)
278;; (toggle-button-active-p button)))))
279
280 (container-add action-area
281 (create-check-button "Show Opacity"
282 #'(lambda (state)
283 (setf (color-selection-has-opacity-control-p colorsel) state))))
284
285 (container-add action-area
286 (create-check-button "Show Palette"
287 #'(lambda (state)
288 (setf (color-selection-has-palette-p colorsel) state))))
289
290 (signal-connect dialog :ok
291 #'(lambda ()
292 (let ((color (color-selection-current-color colorsel)))
293 (format t "Selected color: ~A~%" color)
294 (setf (color-selection-current-color colorsel) color)
295 (widget-hide dialog))))
0d07716f 296
35ec512c 297 (signal-connect dialog :cancel #'widget-destroy :object t)))
0d07716f 298
0d07716f 299
300;;; Cursors
301
302(defun clamp (n min-val max-val)
303 (declare (number n min-val max-val))
304 (max (min n max-val) min-val))
305
af5eb952 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))
0d07716f 350
af5eb952 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))
0d07716f 357
af5eb952 358 (signal-connect spinner 'changed
359 #'(lambda ()
360 (set-cursor spinner drawing-area label)))
0d07716f 361
af5eb952 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)))
0d07716f 380
381
382;;; Dialog
383
35ec512c 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))))))
0d07716f 403
35ec512c 404 (if (widget-visible-p dialog)
405 (widget-hide dialog)
406 (widget-show dialog))))
0d07716f 407
408
409;; Entry
410
35ec512c 411(define-simple-dialog create-entry (dialog "Entry")
412 (let ((main (make-instance 'v-box
413 :border-width 10 :spacing 10 :parent dialog)))
4fb50b71 414
35ec512c 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)
4fb50b71 420
e52cf822 421 (let ((combo (make-instance 'combo-box-entry
35ec512c 422 :parent main
e52cf822 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)))
35ec512c 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)))
0d07716f 450
0d07716f 451
36c95ad8 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
0d07716f 462
35ec512c 463;; File chooser dialog
0d07716f 464
35ec512c 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 ()
7c1f9a1e 469 (if (slot-boundp dialog 'filename)
470 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
471 (write-line "No files selected"))
35ec512c 472 (widget-destroy dialog))))
0d07716f 473
474
475
476;;; Handle box
477
35ec512c 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)))
0d07716f 484
35ec512c 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)))
0d07716f 489
35ec512c 490;; (toolbar-append-space toolbar)
0d07716f 491
35ec512c 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)))
0d07716f 496
35ec512c 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)))
0d07716f 501
35ec512c 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)))
0d07716f 506
35ec512c 507;; (toolbar-append-space toolbar)
0d07716f 508
35ec512c 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)))
0d07716f 513
35ec512c 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)))
0d07716f 518
35ec512c 519;; (toolbar-append-space toolbar)
0d07716f 520
35ec512c 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)))
0d07716f 525
35ec512c 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)))
0d07716f 530
35ec512c 531;; (toolbar-append-space toolbar)
0d07716f 532
35ec512c 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)))
0d07716f 537
35ec512c 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)))
0d07716f 542
35ec512c 543;; toolbar))
0d07716f 544
545
35ec512c 546;; (defun handle-box-child-signal (handle-box child action)
547;; (format t "~S: child ~S ~A~%" handle-box child action))
0d07716f 548
549
35ec512c 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)
0d07716f 557
e52cf822 558;; (container-add v-box (create-label "Above"))
35ec512c 559;; (container-add v-box (hseparator-new))
0d07716f 560
35ec512c 561;; (let ((hbox (hbox-new nil 10)))
562;; (container-add v-box hbox)
0d07716f 563
35ec512c 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")))
e52cf822 597;; (container-add handle-box2 (create-label "Foo!")))))
0d07716f 598
35ec512c 599;; (container-add v-box (hseparator-new))
e52cf822 600;; (container-add v-box (create-label "Below"))))
35ec512c 601
602;;; Image
0d07716f 603
35ec512c 604(define-toplevel create-image (window "Image")
605 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
0d07716f 606
607
608;;; Labels
609
35ec512c 610(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
4fb50b71 611 (flet ((create-label-in-frame (frame-label label-text &rest args)
612 (list
613 (make-instance 'frame
614 :label frame-label
35ec512c 615 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
4fb50b71 616 :fill nil :expand nil)))
35ec512c 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"
0d07716f 624"This is a Multi-line label.
625Second line
4fb50b71 626Third line")
35ec512c 627 :child (create-label-in-frame "Left Justified Label"
0d07716f 628"This is a Left-Justified
629Multi-line.
4fb50b71 630Third line"
35ec512c 631 :justify :left)
632 :child (create-label-in-frame "Right Justified Label"
0d07716f 633"This is a Right-Justified
634Multi-line.
4fb50b71 635Third line"
35ec512c 636 :justify :right))
637 :child (make-instance 'v-box
638 :spacing 5
639 :child (create-label-in-frame "Line wrapped label"
0d07716f 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.
4fb50b71 641 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
35ec512c 642 :wrap t)
643
644 :child (create-label-in-frame "Filled, wrapped label"
0d07716f 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.
4fb50b71 647 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
35ec512c 648 :justify :fill :wrap t)
649
650 :child (create-label-in-frame "Underlined label"
0d07716f 651"This label is underlined!
4fb50b71 652This one is underlined (こんにちは) in quite a funky fashion"
35ec512c 653 :justify :left
654 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
0d07716f 655
656
657;;; Layout
658
af5eb952 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)
35ec512c 678
679(define-toplevel create-layout (window "Layout" :default-width 200
680 :default-height 200)
4fb50b71 681 (let ((layout (make-instance 'layout
682 :parent (make-instance 'scrolled-window :parent window)
35ec512c 683 :width 1600 :height 128000 :events '(:exposure-mask)
af5eb952 684 :signal (list 'expose-event #'layout-expose :object t)
35ec512c 685 )))
4fb50b71 686
687 (with-slots (hadjustment vadjustment) layout
688 (setf
689 (adjustment-step-increment hadjustment) 10.0
690 (adjustment-step-increment vadjustment) 10.0))
0d07716f 691
692 (dotimes (i 16)
693 (dotimes (j 16)
35ec512c 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))))))
0d07716f 699
35ec512c 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)))))))
4fb50b71 707
0d07716f 708
709
710;;; List
711
549265c1 712(define-simple-dialog create-list (dialog "List" :default-height 400)
744118a7 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)))
0d07716f 719
549265c1 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))
744118a7 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))))
0d07716f 801
802
803;; Menus
804
805(defun create-menu (depth tearoff)
806 (unless (zerop depth)
35ec512c 807 (let ((menu (make-instance 'menu)))
0d07716f 808 (when tearoff
35ec512c 809 (let ((menu-item (make-instance 'tearoff-menu-item)))
810 (menu-shell-append menu menu-item)))
0d07716f 811 (let ((group nil))
812 (dotimes (i 5)
35ec512c 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))
0d07716f 819 (unless (zerop (mod depth 2))
35ec512c 820 (setf (check-menu-item-active-p menu-item) t))
821 (menu-shell-append menu menu-item)
0d07716f 822 (when (= i 3)
35ec512c 823 (setf (widget-sensitive-p menu-item) nil))
824 (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
4fb50b71 825 menu)))
0d07716f 826
827
35ec512c 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
e52cf822 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))))
0d07716f 855
e52cf822 856 (widget-show-all main)))
0d07716f 857
858
859;;; Notebook
860
35ec512c 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))))
0d07716f 913
0d07716f 914
35ec512c 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))
e52cf822 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)))
35ec512c 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)))
0d07716f 1018
1019
1020;;; Panes
1021
1022(defun toggle-resize (child)
7c1f9a1e 1023 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
0d07716f 1024
1025(defun toggle-shrink (child)
7c1f9a1e 1026 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
0d07716f 1027
1028(defun create-pane-options (paned frame-label label1 label2)
7c1f9a1e 1029 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
81f2aa93 1030 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
35ec512c 1031 (let ((check-button (make-instance 'check-button :label "Resize")))
81f2aa93 1032 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 1036 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
7c1f9a1e 1037 (signal-connect check-button 'toggled
1038 #'toggle-shrink :object (paned-child1 paned)))
0d07716f 1039
81f2aa93 1040 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
7c1f9a1e 1041 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
81f2aa93 1042 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 1046 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
7c1f9a1e 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)))
0d07716f 1050
35ec512c 1051(define-toplevel create-panes (window "Panes")
1052 (let* ((hpaned (make-instance 'h-paned
4fb50b71 1053 :child1 (make-instance 'frame
35ec512c 1054 :width-request 60 :height-request 60
1055 :shadow-type :in
7c1f9a1e 1056 :child (make-instance 'button :label "Hi there"))
35ec512c 1057 :child2 (make-instance 'frame
1058 :width-request 80 :height-request 60
1059 :shadow-type :in)))
1060 (vpaned (make-instance 'v-paned
4fb50b71 1061 :border-width 5
1062 :child1 hpaned
1063 :child2 (make-instance 'frame
35ec512c 1064 :width-request 80 :height-request 60
1065 :shadow-type :in))))
4fb50b71 1066
35ec512c 1067 (make-instance 'v-box
4fb50b71 1068 :parent window
35ec512c 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"))))
0d07716f 1073
1074
0d07716f 1075;;; Progress bar
1076
7c1f9a1e 1077
0d07716f 1078
1079
1080;;; Radio buttons
1081
35ec512c 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)))
0d07716f 1086
1087
1088;;; Rangle controls
1089
35ec512c 1090(define-simple-dialog create-range-controls (dialog "Range controls")
0d07716f 1091 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
35ec512c 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))))
0d07716f 1099
1100
1101;;; Reparent test
1102
35ec512c 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")))
0d07716f 1107
35ec512c 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)))
0d07716f 1118
35ec512c 1119 (box-pack-start (create-frame "Frame 1") label nil t 0)
1120 (create-frame "Frame 2"))
1121 (widget-show-all main)))
0d07716f 1122
1123
1124;;; Rulers
1125
35ec512c 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
81f2aa93 1135 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1136 (h-ruler (make-instance 'h-ruler
35ec512c 1137 :metric :centimeters :lower 100.0d0 :upper 0.0d0
81f2aa93 1138 :position 0.0d0 :max-size 20.0d0))
1139 (v-ruler (make-instance 'v-ruler
35ec512c 1140 :lower 5.0d0 :upper 15.0d0
1141 :position 0.0d0 :max-size 20.0d0)))
81f2aa93 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)))
0d07716f 1148
1149
1150;;; Scrolled window
1151
35ec512c 1152(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1153 :default-width 300
1154 :default-height 300)
4fb50b71 1155 (let* ((scrolled-window
1156 (make-instance 'scrolled-window
35ec512c 1157 :parent dialog :border-width 10
1158 :vscrollbar-policy :automatic
4fb50b71 1159 :hscrollbar-policy :automatic))
1160 (table
1161 (make-instance 'table
35ec512c 1162 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
4fb50b71 1163 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1164 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
0d07716f 1165
0d07716f 1166 (scrolled-window-add-with-viewport scrolled-window table)
0d07716f 1167 (dotimes (i 20)
1168 (dotimes (j 20)
1169 (let ((button
35ec512c 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)))
0d07716f 1174
1175
81f2aa93 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
0d07716f 1212;;; Shapes
1213
35ec512c 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)))
4fb50b71 1222
35ec512c 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)
4fb50b71 1231
35ec512c 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))
0d07716f 1250
35ec512c 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)))
0d07716f 1261
35ec512c 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)))))
0d07716f 1294
1295
1296
1297;;; Spin buttons
1298
35ec512c 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 : "
5ff67599 1319 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
35ec512c 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)))
0d07716f 1395
35ec512c 1396
5ff67599 1397;;; Statusbar
0d07716f 1398
5ff67599 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)))
0d07716f 1433
1434
1435;;; Idle test
1436
e025589b 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))))
0d07716f 1444
e025589b 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))))))
0d07716f 1469
e025589b 1470 (dialog-add-button dialog "Stop"
1471 #'(lambda ()
1472 (when idle
1473 (idle-remove idle)
1474 (setq idle nil))))))
0d07716f 1475
1476
1477
1478;;; Timeout test
1479
e025589b 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))))))
7932cfab 1503
1504
1505;;; Text
1506
1507(define-simple-dialog create-text (dialog "Text" :default-width 400
1508 :default-height 400)
81f2aa93 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
0d07716f 1589
0d07716f 1590;;; Toggle buttons
1591
35ec512c 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))))))
0d07716f 1599
1600
1601
1602;;; Toolbar test
1603
35ec512c 1604(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1605 (let ((toolbar (make-instance 'toolbar :parent window)))
0d07716f 1606
35ec512c 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)))
0d07716f 1612
35ec512c 1613 ;; Image widge as icon
1614 (toolbar-append toolbar "Horizontal"
1615 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
0d07716f 1616 :tooltip-text "Horizontal toolbar layout"
1617 :tooltip-private-text "Toolbar/Horizontal"
1618 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1619
35ec512c 1620 ;; Icon from file
1621 (toolbar-append toolbar "Vertical"
1622 :icon #p"clg:examples;test.xpm"
0d07716f 1623 :tooltip-text "Vertical toolbar layout"
1624 :tooltip-private-text "Toolbar/Vertical"
1625 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1626
35ec512c 1627 (toolbar-append toolbar :space)
0d07716f 1628
35ec512c 1629 ;; Stock icon
1630 (toolbar-append toolbar "Icons"
1631 :icon "gtk-execute"
0d07716f 1632 :tooltip-text "Only show toolbar icons"
1633 :tooltip-private-text "Toolbar/IconsOnly"
1634 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1635
35ec512c 1636 ;; Icon from pixmap data
1637 (toolbar-append toolbar "Text"
1638 :icon gtk-mini-xpm
0d07716f 1639 :tooltip-text "Only show toolbar text"
1640 :tooltip-private-text "Toolbar/TextOnly"
1641 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1642
35ec512c 1643 (toolbar-append toolbar "Both"
0d07716f 1644 :tooltip-text "Show toolbar icons and text"
1645 :tooltip-private-text "Toolbar/Both"
1646 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1647
35ec512c 1648 (toolbar-append toolbar :space)
0d07716f 1649
35ec512c 1650 (toolbar-append toolbar (make-instance 'entry)
1651 :tooltip-text "This is an unusable GtkEntry"
0d07716f 1652 :tooltip-private-text "Hey don't click me!")
1653
35ec512c 1654 (toolbar-append toolbar :space)
0d07716f 1655
35ec512c 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)))
0d07716f 1661
35ec512c 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)))
0d07716f 1667
35ec512c 1668;; (toolbar-append toolbar :space)
0d07716f 1669
35ec512c 1670 (toolbar-append
1671 toolbar "Enable"
0d07716f 1672 :tooltip-text "Enable tooltips"
1673 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1674
35ec512c 1675 (toolbar-append
1676 toolbar "Disable"
0d07716f 1677 :tooltip-text "Disable tooltips"
1678 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1679
35ec512c 1680 (toolbar-append toolbar :space)
0d07716f 1681
35ec512c 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)))
0d07716f 1686
35ec512c 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)))
4fb50b71 1704
35ec512c 1705 ))
0d07716f 1706
1707
1708
1709;;; Tooltips test
1710
e025589b 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")
7c1f9a1e 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")))))
7932cfab 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
81f2aa93 1752(define-toplevel create-ui-manager (window "UI Manager")
7932cfab 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")
81f2aa93 1762 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
7932cfab 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")
81f2aa93 1765 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
7932cfab 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
81f2aa93 1783 (window-add-accel-group window (ui-manager-accel-group ui))
7932cfab 1784
1785 (make-instance 'v-box
81f2aa93 1786 :parent window :show-all t
7932cfab 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))))
0d07716f 1797
1798
1799
0d07716f 1800;;; Main window
1801
1802(defun create-main-window ()
35ec512c 1803;; (rc-parse "clg:examples;testgtkrc2")
1804;; (rc-parse "clg:examples;testgtkrc")
4fb50b71 1805
1806 (let* ((button-specs
0d07716f 1807 '(("button box" create-button-box)
35ec512c 1808 ("buttons" create-buttons)
1809 ("calendar" create-calendar)
1810 ("check buttons" create-check-buttons)
35ec512c 1811 ("color selection" create-color-selection)
af5eb952 1812 ("cursors" create-cursors)
35ec512c 1813 ("dialog" create-dialog)
1814;; ; ("dnd")
1815 ("entry" create-entry)
1816;; ("event watcher")
36c95ad8 1817 ("enxpander" create-expander)
35ec512c 1818 ("file chooser" create-file-chooser)
1819;; ("font selection")
1820;; ("handle box" create-handle-box)
1821 ("image" create-image)
35ec512c 1822 ("labels" create-labels)
1823 ("layout" create-layout)
549265c1 1824 ("list" create-list)
0d07716f 1825 ("menus" create-menus)
35ec512c 1826;; ("modal window")
1827 ("notebook" create-notebook)
1828 ("panes" create-panes)
35ec512c 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)
81f2aa93 1837 ("size group" create-size-group)
35ec512c 1838;; ("shapes" create-shapes)
1839 ("spinbutton" create-spins)
5ff67599 1840 ("statusbar" create-statusbar)
e025589b 1841 ("test idle" create-idle-test)
35ec512c 1842;; ("test mainloop")
1843;; ("test scrolling")
1844;; ("test selection")
e025589b 1845 ("test timeout" create-timeout-test)
7932cfab 1846 ("text" create-text)
35ec512c 1847 ("toggle buttons" create-toggle-buttons)
1848 ("toolbar" create-toolbar)
e025589b 1849 ("tooltips" create-tooltips)
35ec512c 1850;; ("tree" #|create-tree|#)
7932cfab 1851 ("UI manager" create-ui-manager)
35ec512c 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))))
0d07716f 1865
7c1f9a1e 1866 (setf (window-icon main-window) #p"clg:examples;gtk.png")
1867
0d07716f 1868 ;; Main box
35ec512c 1869 (make-instance 'v-box
0d07716f 1870 :parent main-window
35ec512c 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))
0d07716f 1887
35ec512c 1888 (widget-grab-focus close-button)
0d07716f 1889 (widget-show-all main-window)
1890 main-window))
1891
35ec512c 1892(clg-init)
1893(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).