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