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