chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Added selection in list and tree widgets
[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
21f6214a 18;; $Id: testgtk.lisp,v 1.6 2004-11-15 19:33:21 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)
58 (dialog-add-button ,dialog "Close" #'widget-destroy :object t)
59 ,@body))
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
187 :child (make-instance 'button :label "OK")
188 :child (make-instance 'button :label "Cancel")
189 :child (make-instance 'button :label "Help"))))
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))))
704a1de4 241 (table-attach table button column (1+ column) row (1+ row)))))
242 (widget-show-all table)))
560af5c5 243
244
245;; Calenadar
246
704a1de4 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)))
560af5c5 251
252
253;;; Check buttons
254
704a1de4 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)))))
560af5c5 262
263
264
265;;; Color selection
266
704a1de4 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))))
560af5c5 295
704a1de4 296 (signal-connect dialog :cancel #'widget-destroy :object t)))
560af5c5 297
560af5c5 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
560af5c5 305
613fb570 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)))
196fe1e9 313
560af5c5 314
196fe1e9 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))
613fb570 319; (label (create-label "Cursor Value : "))
196fe1e9 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)))))
560af5c5 389
390
391
392;;; Dialog
393
704a1de4 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))))))
560af5c5 413
704a1de4 414 (if (widget-visible-p dialog)
415 (widget-hide dialog)
416 (widget-show dialog))))
560af5c5 417
418
419;; Entry
420
704a1de4 421(define-simple-dialog create-entry (dialog "Entry")
422 (let ((main (make-instance 'v-box
423 :border-width 10 :spacing 10 :parent dialog)))
196fe1e9 424
704a1de4 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)
196fe1e9 430
613fb570 431 (let ((combo (make-instance 'combo-box-entry
704a1de4 432 :parent main
613fb570 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)))
704a1de4 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)))
560af5c5 460
560af5c5 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
704a1de4 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)
196fe1e9 685 (let ((layout (make-instance 'layout
686 :parent (make-instance 'scrolled-window :parent window)
704a1de4 687 :width 1600 :height 128000 :events '(:exposure-mask)
688;; :signal (list 'expose-event #'layout-expose :object t)
689 )))
196fe1e9 690
691 (with-slots (hadjustment vadjustment) layout
692 (setf
693 (adjustment-step-increment hadjustment) 10.0
694 (adjustment-step-increment vadjustment) 10.0))
560af5c5 695
696 (dotimes (i 16)
697 (dotimes (j 16)
704a1de4 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))))))
560af5c5 703
704a1de4 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)))))))
196fe1e9 711
560af5c5 712
713
714;;; List
715
21f6214a 716(define-simple-dialog create-list (dialog "List" :default-height 400)
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)))))
560af5c5 722
21f6214a 723 (loop
724 with iter = (make-instance 'tree-iter)
725 for i from 1 to 1000
726 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
727
728 (let ((tree (make-instance 'tree-view :model store)))
729 (let ((column (make-instance 'tree-view-column :title "Column 1"))
730 (cell (make-instance 'cell-renderer-text)))
731 (cell-layout-pack column cell)
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)
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)
744 (cell-layout-add-attribute column cell 'text (column-index store :baz))
745 (tree-view-append-column tree column))
746
747 (make-instance 'scrolled-window
748 :parent dialog :child tree :show-all t :border-width 10
749 :hscrollbar-policy :automatic))))
560af5c5 750
751
752;; Menus
753
754(defun create-menu (depth tearoff)
755 (unless (zerop depth)
704a1de4 756 (let ((menu (make-instance 'menu)))
560af5c5 757 (when tearoff
704a1de4 758 (let ((menu-item (make-instance 'tearoff-menu-item)))
759 (menu-shell-append menu menu-item)))
560af5c5 760 (let ((group nil))
761 (dotimes (i 5)
704a1de4 762 (let ((menu-item
763 (make-instance 'radio-menu-item
764 :label (format nil "item ~2D - ~D" depth (1+ i)))))
765 (if group
766 (radio-menu-item-add-to-group menu-item group)
767 (setq group menu-item))
560af5c5 768 (unless (zerop (mod depth 2))
704a1de4 769 (setf (check-menu-item-active-p menu-item) t))
770 (menu-shell-append menu menu-item)
560af5c5 771 (when (= i 3)
704a1de4 772 (setf (widget-sensitive-p menu-item) nil))
773 (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
196fe1e9 774 menu)))
560af5c5 775
776
704a1de4 777(define-simple-dialog create-menus (dialog "Menus" :default-width 200)
778 (let* ((main (make-instance 'v-box :parent dialog))
779; (accel-group (make-instance 'accel-group))
780 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
781; (accel-group-attach accel-group window)
782
783 (let ((menu-item (make-instance 'menu-item
784 :label (format nil "test~%line2"))))
785 (setf (menu-item-submenu menu-item) (create-menu 2 t))
786 (menu-shell-append menubar menu-item))
787
788 (let ((menu-item (make-instance 'menu-item :label "foo")))
789 (setf (menu-item-submenu menu-item) (create-menu 3 t))
790 (menu-shell-append menubar menu-item))
791
792 (let ((menu-item (make-instance 'menu-item :label "bar")))
793 (setf (menu-item-submenu menu-item) (create-menu 4 t))
794 (setf (menu-item-right-justified-p menu-item) t)
795 (menu-shell-append menubar menu-item))
796
613fb570 797 (make-instance 'v-box
798 :spacing 10 :border-width 10 :parent main
799 :child (make-instance 'combo-box
800 :active 3
801 :content (loop
802 for i from 1 to 5
803 collect (format nil "Item ~D" i))))
560af5c5 804
613fb570 805 (widget-show-all main)))
560af5c5 806
807
808;;; Notebook
809
704a1de4 810(defun create-notebook-page (notebook page-num)
811 (let* ((title (format nil "Page ~D" page-num))
812 (page (make-instance 'frame :label title :border-width 10))
813 (v-box (make-instance 'v-box
814 :homogeneous t :border-width 10 :parent page)))
815
816 (make-instance 'h-box
817 :parent (list v-box :fill nil :padding 5) :homogeneous t
818 :child-args '(:padding 5)
819 :child (make-instance 'check-button
820 :label "Fill Tab" :active t
821 :signal (list 'toggled
822 #'(lambda (button)
823 (setf
824 (notebook-child-tab-fill-p page)
825 (toggle-button-active-p button)))
826 :object t))
827 :child (make-instance 'check-button
828 :label "Expand Tab"
829 :signal (list 'toggled
830 #'(lambda (button)
831 (setf
832 (notebook-child-tab-expand-p page)
833 (toggle-button-active-p button)))
834 :object t))
835 :child (make-instance 'check-button
836 :label "Pack end"
837 :signal (list 'toggled
838 #'(lambda (button)
839 (setf
840 (notebook-child-tab-pack page)
841 (if (toggle-button-active-p button)
842 :end
843 :start)))
844 :object t))
845 :child (make-instance 'button
846 :label "Hide page"
847 :signal (list 'clicked #'(lambda () (widget-hide page)))))
848
849 (let ((label-box (make-instance 'h-box
850 :show-all t
851 :child-args '(:expand nil)
852 :child (make-instance 'image :pixmap book-closed-xpm)
853 :child (make-instance 'label :label title)))
854 (menu-box (make-instance 'h-box
855 :show-all t
856 :child-args '(:expand nil)
857 :child (make-instance 'image :pixmap book-closed-xpm)
858 :child (make-instance 'label :label title))))
859
860 (widget-show-all page)
861 (notebook-append notebook page label-box menu-box))))
560af5c5 862
560af5c5 863
704a1de4 864(define-simple-dialog create-notebook (dialog "Notebook")
865 (let ((main (make-instance 'v-box :parent dialog)))
866 (let ((notebook (make-instance 'notebook
867 :border-width 10 :tab-pos :top :parent main)))
868 (flet ((set-image (page func xpm)
869 (image-set-from-pixmap-data
870 (first (container-children (funcall func notebook page)))
871 xpm)))
872 (signal-connect notebook 'switch-page
873 #'(lambda (pointer page)
874 (declare (ignore pointer))
875 (unless (eq page (notebook-current-page-num notebook))
876 (set-image page #'notebook-menu-label book-open-xpm)
877 (set-image page #'notebook-tab-label book-open-xpm)
878
879 (let ((curpage (notebook-current-page notebook)))
880 (when curpage
881 (set-image curpage #'notebook-menu-label book-closed-xpm)
882 (set-image curpage #'notebook-tab-label book-closed-xpm)))))))
883 (loop for i from 1 to 5 do (create-notebook-page notebook i))
884
885 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
886
887 (make-instance 'h-box
888 :spacing 5 :border-width 10
889 :parent (list main :expand nil)
890 :child-args '(:fill nil)
891 :child (make-instance 'check-button
892 :label "Popup menu"
893 :signal (list 'clicked
894 #'(lambda (button)
895 (if (toggle-button-active-p button)
896 (notebook-popup-enable notebook)
897 (notebook-popup-disable notebook)))
898 :object t))
899 :child (make-instance 'check-button
900 :label "Homogeneous tabs"
901 :signal (list 'clicked
902 #'(lambda (button)
903 (setf
904 (notebook-homogeneous-p notebook)
905 (toggle-button-active-p button)))
906 :object t)))
907
908 (make-instance 'h-box
909 :spacing 5 :border-width 10
910 :parent (list main :expand nil)
911 :child-args '(:expand nil)
912 :child (make-instance 'label :label "Notebook Style: ")
913 :child (let ((scrollable-p nil))
613fb570 914 ;; option menu is deprecated, we should use combo-box
915 (make-instance 'combo-box
916 :content '("Standard" "No tabs" "Scrollable") :active 0
917 :signal (list 'changed
918 #'(lambda (combo-box)
919 (case (combo-box-active combo-box)
920 (0
921 (setf (notebook-show-tabs-p notebook) t)
922 (when scrollable-p
923 (setq scrollable-p nil)
924 (setf (notebook-scrollable-p notebook) nil)
925 (loop repeat 10
926 do (notebook-remove-page notebook 5))))
927 (1
928 (setf (notebook-show-tabs-p notebook) nil)
929 (when scrollable-p
930 (setq scrollable-p nil)
931 (setf (notebook-scrollable-p notebook) nil)
932 (loop repeat 10
933 do (notebook-remove-page notebook 5))))
934 (2
935 (unless scrollable-p
936 (setq scrollable-p t)
937 (setf (notebook-show-tabs-p notebook) t)
938 (setf (notebook-scrollable-p notebook) t)
939 (loop for i from 6 to 15
940 do (create-notebook-page notebook i))))))
941 :object t)))
704a1de4 942 :child (make-instance 'button
943 :label "Show all Pages"
944 :signal (list 'clicked
945 #'(lambda ()
946 (map-container nil #'widget-show notebook)))))
947
948 (make-instance 'h-box
949 :spacing 5 :border-width 10
950 :parent (list main :expand nil)
951 :child (make-instance 'button
952 :label "prev"
953 :signal (list 'clicked #'notebook-prev-page :object notebook))
954 :child (make-instance 'button
955 :label "next"
956 :signal (list 'clicked #'notebook-next-page :object notebook))
957 :child (make-instance 'button
958 :label "rotate"
959 :signal (let ((tab-pos 0))
960 (list 'clicked
961 #'(lambda ()
962 (setq tab-pos (mod (1+ tab-pos) 4))
963 (setf
964 (notebook-tab-pos notebook)
965 (svref #(:top :right :bottom :left) tab-pos))))))))
966 (widget-show-all main)))
560af5c5 967
968
969;;; Panes
970
971(defun toggle-resize (child)
972 (let* ((paned (widget-parent child))
973 (is-child1-p (eq child (paned-child1 paned))))
974 (multiple-value-bind (child resize shrink)
975 (if is-child1-p
976 (paned-child1 paned)
977 (paned-child2 paned))
560af5c5 978 (container-remove paned child)
979 (if is-child1-p
980 (paned-pack1 paned child (not resize) shrink)
196fe1e9 981 (paned-pack2 paned child (not resize) shrink)))))
560af5c5 982
983(defun toggle-shrink (child)
984 (let* ((paned (widget-parent child))
985 (is-child1-p (eq child (paned-child1 paned))))
986 (multiple-value-bind (child resize shrink)
987 (if is-child1-p
988 (paned-child1 paned)
989 (paned-child2 paned))
560af5c5 990 (container-remove paned child)
991 (if is-child1-p
992 (paned-pack1 paned child resize (not shrink))
196fe1e9 993 (paned-pack2 paned child resize (not shrink))))))
560af5c5 994
995(defun create-pane-options (paned frame-label label1 label2)
704a1de4 996 (let* ((frame (make-instance 'frame :label frame-label :border-width 4))
997 (table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t
998 :parent frame)))
560af5c5 999
613fb570 1000 (table-attach table (create-label label1) 0 1 0 1)
704a1de4 1001 (let ((check-button (make-instance 'check-button :label "Resize")))
560af5c5 1002 (table-attach table check-button 0 1 1 2)
1003 (signal-connect
1004 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
704a1de4 1005 (let ((check-button (make-instance 'check-button :label "Shrink")))
560af5c5 1006 (table-attach table check-button 0 1 2 3)
1007 (setf (toggle-button-active-p check-button) t)
1008 (signal-connect
1009 check-button 'toggled #'toggle-shrink :object (paned-child1 paned)))
1010
613fb570 1011 (table-attach table (create-label label2) 1 2 0 1)
704a1de4 1012 (let ((check-button (make-instance 'check-button :label "Resize")))
560af5c5 1013 (table-attach table check-button 1 2 1 2)
1014 (setf (toggle-button-active-p check-button) t)
1015 (signal-connect
1016 check-button 'toggled #'toggle-resize :object (paned-child2 paned)))
704a1de4 1017 (let ((check-button (make-instance 'check-button :label "Shrink")))
560af5c5 1018 (table-attach table check-button 1 2 2 3)
1019 (setf (toggle-button-active-p check-button) t)
1020 (signal-connect
1021 check-button 'toggled #'toggle-shrink :object (paned-child2 paned)))
560af5c5 1022 frame))
1023
704a1de4 1024(define-toplevel create-panes (window "Panes")
1025 (let* ((hpaned (make-instance 'h-paned
196fe1e9 1026 :child1 (make-instance 'frame
704a1de4 1027 :width-request 60 :height-request 60
1028 :shadow-type :in
613fb570 1029 :child (make-instance 'buttun :label "Hi there"))
704a1de4 1030 :child2 (make-instance 'frame
1031 :width-request 80 :height-request 60
1032 :shadow-type :in)))
1033 (vpaned (make-instance 'v-paned
196fe1e9 1034 :border-width 5
1035 :child1 hpaned
1036 :child2 (make-instance 'frame
704a1de4 1037 :width-request 80 :height-request 60
1038 :shadow-type :in))))
196fe1e9 1039
704a1de4 1040 (make-instance 'v-box
196fe1e9 1041 :parent window
704a1de4 1042 :child-args '(:expand nil)
1043 :child (list vpaned :expand t)
1044 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1045 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
560af5c5 1046
1047
560af5c5 1048;;; Progress bar
1049
196fe1e9 1050
560af5c5 1051
1052
1053;;; Radio buttons
1054
704a1de4 1055(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1056 (make-instance 'v-box
1057 :parent dialog :border-width 10 :spacing 10 :show-all t
1058 :children (create-radio-button-group '("button1" "button2" "button3") 1)))
560af5c5 1059
1060
1061;;; Rangle controls
1062
704a1de4 1063(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1064 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 1065 (make-instance 'v-box
1066 :parent dialog :border-width 10 :spacing 10 :show-all t
1067 :child (make-instance 'h-scale
1068 :width-request 150 :adjustment adjustment :inverted t
1069 :update-policy :delayed :digits 1 :draw-value t)
1070 :child (make-instance 'h-scrollbar
1071 :adjustment adjustment :update-policy :continuous))))
560af5c5 1072
1073
1074;;; Reparent test
1075
704a1de4 1076(define-simple-dialog create-reparent (dialog "Reparent")
1077 (let ((main (make-instance 'h-box
1078 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
1079 (label (make-instance 'label :label "Hellow World")))
560af5c5 1080
704a1de4 1081 (flet ((create-frame (title)
1082 (let* ((frame (make-instance 'frame :label title :parent main))
1083 (box (make-instance 'v-box
1084 :spacing 5 :border-width 5 :parent frame))
1085 (button (make-instance 'button
1086 :label "switch" :parent (list box :expand nil))))
1087 (signal-connect button 'clicked
1088 #'(lambda ()
1089 (widget-reparent label box)))
1090 box)))
560af5c5 1091
704a1de4 1092 (box-pack-start (create-frame "Frame 1") label nil t 0)
1093 (create-frame "Frame 2"))
1094 (widget-show-all main)))
560af5c5 1095
1096
1097;;; Rulers
1098
704a1de4 1099(define-toplevel create-rulers (window "Rulers"
1100 :default-width 300 :default-height 300
1101;; :events '(:pointer-motion-mask
1102;; :pointer-motion-hint-mask)
1103 )
1104 (setf
1105 (widget-events window)
1106 '(:pointer-motion-mask :pointer-motion-hint-mask))
1107
1108 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window)))
1109 (let ((ruler (make-instance 'h-ruler
1110 :metric :centimeters :lower 100.0d0 :upper 0.0d0
1111 :position 0.0d0 :max-size 20.0d0)))
1112 (signal-connect window 'motion-notify-event #'widget-event :object ruler)
196fe1e9 1113 (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
704a1de4 1114 (let ((ruler (make-instance 'v-ruler
1115 :lower 5.0d0 :upper 15.0d0
1116 :position 0.0d0 :max-size 20.0d0)))
1117 (signal-connect window 'motion-notify-event #'widget-event :object ruler)
196fe1e9 1118 (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
560af5c5 1119
1120
1121
1122;;; Scrolled window
1123
704a1de4 1124(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1125 :default-width 300
1126 :default-height 300)
196fe1e9 1127 (let* ((scrolled-window
1128 (make-instance 'scrolled-window
704a1de4 1129 :parent dialog :border-width 10
1130 :vscrollbar-policy :automatic
196fe1e9 1131 :hscrollbar-policy :automatic))
1132 (table
1133 (make-instance 'table
704a1de4 1134 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1135 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1136 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1137
560af5c5 1138 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1139 (dotimes (i 20)
1140 (dotimes (j 20)
1141 (let ((button
704a1de4 1142 (make-instance 'toggle-button
1143 :label (format nil "button (~D,~D)~%" i j))))
1144 (table-attach table button i (1+ i) j (1+ j)))))
1145 (widget-show-all scrolled-window)))
560af5c5 1146
1147
1148;;; Shapes
1149
704a1de4 1150;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1151;; (let* ((window
1152;; (make-instance 'window
1153;; :type type :x x :y y
1154;; :events '(:button-motion :pointer-motion-hint :button-press)))
1155;; (fixed
1156;; (make-instance 'fixed
1157;; :parent window :width 100 :height 100)))
196fe1e9 1158
704a1de4 1159;; (widget-realize window)
1160;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1161;; (let ((pixmap (pixmap-new source mask))
1162;; (x-offset 0)
1163;; (y-offset 0))
1164;; (declare (fixnum x-offset y-offset))
1165;; (fixed-put fixed pixmap px py)
1166;; (widget-shape-combine-mask window mask px py)
196fe1e9 1167
704a1de4 1168;; (signal-connect window 'button-press-event
1169;; #'(lambda (event)
1170;; (when (typep event 'gdk:button-press-event)
1171;; (setq x-offset (truncate (gdk:event-x event)))
1172;; (setq y-offset (truncate (gdk:event-y event)))
1173;; (grab-add window)
1174;; (gdk:pointer-grab
1175;; (widget-window window) t
1176;; '(:button-release :button-motion :pointer-motion-hint)
1177;; nil nil 0))
1178;; t))
1179
1180;; (signal-connect window 'button-release-event
1181;; #'(lambda (event)
1182;; (declare (ignore event))
1183;; (grab-remove window)
1184;; (gdk:pointer-ungrab 0)
1185;; t))
560af5c5 1186
704a1de4 1187;; (signal-connect window 'motion-notify-event
1188;; #'(lambda (event)
1189;; (declare (ignore event))
1190;; (multiple-value-bind (win xp yp mask)
1191;; (gdk:window-get-pointer root-window)
1192;; (declare (ignore mask win) (fixnum xp yp))
1193;; (widget-set-uposition
1194;; window :x (- xp x-offset) :y (- yp y-offset)))
1195;; t))
1196;; (signal-connect window 'destroy destroy)))
560af5c5 1197
704a1de4 1198;; (widget-show-all window)
1199;; window))
1200
1201
1202;; (let ((modeller nil)
1203;; (sheets nil)
1204;; (rings nil))
1205;; (defun create-shapes ()
1206;; (let ((root-window (gdk:get-root-window)))
1207;; (if (not modeller)
1208;; (setq
1209;; modeller
1210;; (shape-create-icon
1211;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1212;; #'(lambda () (widget-destroyed modeller))))
1213;; (widget-destroy modeller))
1214
1215;; (if (not sheets)
1216;; (setq
1217;; sheets
1218;; (shape-create-icon
1219;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1220;; #'(lambda () (widget-destroyed sheets))))
1221;; (widget-destroy sheets))
1222
1223;; (if (not rings)
1224;; (setq
1225;; rings
1226;; (shape-create-icon
1227;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1228;; #'(lambda () (widget-destroyed rings))))
1229;; (widget-destroy rings)))))
560af5c5 1230
1231
1232
1233;;; Spin buttons
1234
704a1de4 1235(define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1236 (let ((main (make-instance 'v-box
1237 :spacing 5 :border-width 10 :parent dialog)))
1238
1239 (flet ((create-date-spinner (label adjustment shadow-type)
1240 (declare (ignore shadow-type))
1241 (make-instance 'v-box
1242 :child-args '(:expand nil)
1243 :child (make-instance 'label
1244 :label label :xalign 0.0 :yalign 0.5)
1245 :child (make-instance 'spin-button
1246 :adjustment adjustment :wrap t))))
1247 (make-instance 'frame
1248 :label "Not accelerated" :parent main
1249 :child (make-instance 'h-box
1250 :border-width 10
1251 :child-args '(:padding 5)
1252 :child (create-date-spinner "Day : "
1253 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1254 :child (create-date-spinner "Month : "
c775862e 1255 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
704a1de4 1256 :child (create-date-spinner "Year : "
1257 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1258
1259 (let ((spinner1 (make-instance 'spin-button
1260 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1261 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1262 (spinner2 (make-instance 'spin-button
1263 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1264 :climb-rate 1.0 :wrap t))
1265 (value-label (make-instance 'label :label "0")))
1266 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1267 #'(lambda ()
1268 (setf
1269 (spin-button-digits spinner1)
1270 (floor (spin-button-value spinner2)))))
1271
1272 (make-instance 'frame
1273 :label "Accelerated" :parent main
1274 :child (make-instance 'v-box
1275 :border-width 5
1276 :child (list
1277 (make-instance 'h-box
1278 :child-args '(:padding 5)
1279 :child (make-instance 'v-box
1280 :child (make-instance 'label
1281 :label "Value :"
1282 :xalign 0.0 :yalign 0.5)
1283 :child spinner1)
1284 :child (make-instance 'v-box
1285 :child (make-instance 'label
1286 :label "Digits :"
1287 :xalign 0.0 :yalign 0.5)
1288 :child spinner2))
1289 :expand nil :padding 5)
1290 :child (make-instance 'check-button
1291 :label "Snap to 0.5-ticks" :active t
1292 :signal (list 'clicked
1293 #'(lambda (button)
1294 (setf
1295 (spin-button-snap-to-ticks-p spinner1)
1296 (toggle-button-active-p button)))
1297 :object t))
1298 :child (make-instance 'check-button
1299 :label "Numeric only input mode" :active t
1300 :signal (list 'clicked
1301 #'(lambda (button)
1302 (setf
1303 (spin-button-numeric-p spinner1)
1304 (toggle-button-active-p button)))
1305 :object t))
1306 :child value-label
1307 :child (list
1308 (make-instance 'h-box
1309 :child-args '(:padding 5)
1310 :child (make-instance 'button
1311 :label "Value as Int"
1312 :signal (list 'clicked
1313 #'(lambda ()
1314 (setf
1315 (label-label value-label)
1316 (format nil "~D"
1317 (spin-button-value-as-int
1318 spinner1))))))
1319 :child (make-instance 'button
1320 :label "Value as Float"
1321 :signal (list 'clicked
1322 #'(lambda ()
1323 (setf
1324 (label-label value-label)
1325 (format nil
1326 (format nil "~~,~DF"
1327 (spin-button-digits spinner1))
1328 (spin-button-value spinner1)))))))
1329 :padding 5 :expand nil))))
1330 (widget-show-all main)))
560af5c5 1331
704a1de4 1332
c775862e 1333;;; Statusbar
560af5c5 1334
c775862e 1335(define-toplevel create-statusbar (window "Statusbar")
1336 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1337 (close-button (create-button '("close" :can-default t)
1338 #'widget-destroy :object window))
1339 (counter 0))
1340
1341 (signal-connect statusbar 'text-popped
1342 #'(lambda (context-id text)
1343 (declare (ignore context-id))
1344 (format nil "Popped: ~A~%" text)))
1345
1346 (make-instance 'v-box
1347 :parent window
1348 :child (make-instance 'v-box
1349 :border-width 10 :spacing 10
1350 :child (create-button "push something"
1351 #'(lambda ()
1352 (statusbar-push statusbar 1
1353 (format nil "something ~D" (incf counter)))))
1354 :child (create-button "pop"
1355 #'(lambda ()
1356 (statusbar-pop statusbar 1)))
1357 :child (create-button "steal #4"
1358 #'(lambda ()
1359 (statusbar-remove statusbar 1 4)))
1360 :child (create-button "dump stack")
1361 :child (create-button "test contexts"))
1362 :child (list (make-instance 'h-separator) :expand nil)
1363 :child (list
1364 (make-instance 'v-box :border-width 10 :child close-button)
1365 :expand nil)
1366 :child (list statusbar :expand nil))
1367
1368 (widget-grab-focus close-button)))
560af5c5 1369
1370
1371;;; Idle test
1372
704a1de4 1373;; (define-standard-dialog create-idle-test "Idle Test"
1374;; (let* ((container (make-instance 'hbox :parent main-box))
1375;; (label (make-instance 'label
1376;; :label "count: 0" :xpad 10 :ypad 10 :parent container))
1377;; (idle nil)
1378;; (count 0))
1379;; (declare (fixnum count))
1380;; (signal-connect
1381;; window 'destroy #'(lambda () (when idle (idle-remove idle))))
560af5c5 1382
704a1de4 1383;; (make-instance 'frame
1384;; :label "Label Container" :border-width 5 :parent main-box
1385;; :child
1386;; (make-instance 'v-box
1387;; :children
1388;; (create-radio-button-group
1389;; '(("Resize-Parent" :parent)
1390;; ("Resize-Queue" :queue)
1391;; ("Resize-Immediate" :immediate))
1392;; 0
1393;; '(setf container-resize-mode) container)))
1394
1395;; (make-instance 'button
1396;; :label "start" :can-default t :parent action-area
1397;; :signals
1398;; (list
1399;; (list
1400;; 'clicked
1401;; #'(lambda ()
1402;; (unless idle
1403;; (setq
1404;; idle
1405;; (idle-add
1406;; #'(lambda ()
1407;; (incf count)
1408;; (setf (label-label label) (format nil "count: ~D" count))
1409;; t))))))))
560af5c5 1410
704a1de4 1411;; (make-instance 'button
1412;; :label "stop" :can-default t :parent action-area
1413;; :signals
1414;; (list
1415;; (list
1416;; 'clicked
1417;; #'(lambda ()
1418;; (when idle
1419;; (idle-remove idle)
1420;; (setq idle nil))))))))
560af5c5 1421
1422
1423
1424;;; Timeout test
1425
704a1de4 1426;; (define-standard-dialog create-timeout-test "Timeout Test"
1427;; (let ((label (make-instance 'label
1428;; :label "count: 0" :xpad 10 :ypad 10 :parent main-box))
1429;; (timer nil)
1430;; (count 0))
1431;; (declare (fixnum count))
1432;; (signal-connect
1433;; window 'destroy #'(lambda () (when timer (timeout-remove timer))))
196fe1e9 1434
704a1de4 1435;; (make-instance 'button
1436;; :label "start" :can-default t :parent action-area
1437;; :signals
1438;; (list
1439;; (list
1440;; 'clicked
1441;; #'(lambda ()
1442;; (unless timer
1443;; (setq
1444;; timer
1445;; (timeout-add
1446;; 100
1447;; #'(lambda ()
1448;; (incf count)
1449;; (setf (label-label label) (format nil "count: ~D" count))
1450;; t))))))))
1451
1452;; (make-instance 'button
1453;; :label "stop" :can-default t :parent action-area
1454;; :signals
1455;; (list
1456;; (list
1457;; 'clicked
1458;; #'(lambda ()
1459;; (when timer
1460;; (timeout-remove timer)
1461;; (setq timer nil))))))))
560af5c5 1462
1463
560af5c5 1464;;; Toggle buttons
1465
704a1de4 1466(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1467 (make-instance 'v-box
1468 :border-width 10 :spacing 10 :parent dialog :show-all t
1469 :children (loop
1470 for n from 1 to 3
1471 collect (make-instance 'toggle-button
1472 :label (format nil "Button~D" (1+ n))))))
560af5c5 1473
1474
1475
1476;;; Toolbar test
1477
704a1de4 1478;; TODO: style properties
1479(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1480 (let ((toolbar (make-instance 'toolbar :parent window)))
1481; (setf (toolbar-relief toolbar) :none)
560af5c5 1482
704a1de4 1483 ;; Insert a stock item
1484 (toolbar-append toolbar "gtk-quit"
1485 :tooltip-text "Destroy toolbar"
1486 :tooltip-private-text "Toolbar/Quit"
1487 :callback #'(lambda () (widget-destroy window)))
560af5c5 1488
704a1de4 1489 ;; Image widge as icon
1490 (toolbar-append toolbar "Horizontal"
1491 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
560af5c5 1492 :tooltip-text "Horizontal toolbar layout"
1493 :tooltip-private-text "Toolbar/Horizontal"
1494 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1495
704a1de4 1496 ;; Icon from file
1497 (toolbar-append toolbar "Vertical"
1498 :icon #p"clg:examples;test.xpm"
560af5c5 1499 :tooltip-text "Vertical toolbar layout"
1500 :tooltip-private-text "Toolbar/Vertical"
1501 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1502
704a1de4 1503 (toolbar-append toolbar :space)
560af5c5 1504
704a1de4 1505 ;; Stock icon
1506 (toolbar-append toolbar "Icons"
1507 :icon "gtk-execute"
560af5c5 1508 :tooltip-text "Only show toolbar icons"
1509 :tooltip-private-text "Toolbar/IconsOnly"
1510 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1511
704a1de4 1512 ;; Icon from pixmap data
1513 (toolbar-append toolbar "Text"
1514 :icon gtk-mini-xpm
560af5c5 1515 :tooltip-text "Only show toolbar text"
1516 :tooltip-private-text "Toolbar/TextOnly"
1517 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1518
704a1de4 1519 (toolbar-append toolbar "Both"
560af5c5 1520 :tooltip-text "Show toolbar icons and text"
1521 :tooltip-private-text "Toolbar/Both"
1522 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1523
704a1de4 1524 (toolbar-append toolbar :space)
560af5c5 1525
704a1de4 1526 (toolbar-append toolbar (make-instance 'entry)
1527 :tooltip-text "This is an unusable GtkEntry"
560af5c5 1528 :tooltip-private-text "Hey don't click me!")
1529
704a1de4 1530 (toolbar-append toolbar :space)
560af5c5 1531
704a1de4 1532;; (toolbar-append-item
1533;; toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1534;; :tooltip-text "Use small spaces"
1535;; :tooltip-private-text "Toolbar/Small"
1536;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
560af5c5 1537
704a1de4 1538;; (toolbar-append-item
1539;; toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1540;; :tooltip-text "Use big spaces"
1541;; :tooltip-private-text "Toolbar/Big"
1542;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
560af5c5 1543
704a1de4 1544;; (toolbar-append toolbar :space)
560af5c5 1545
704a1de4 1546 (toolbar-append
1547 toolbar "Enable"
560af5c5 1548 :tooltip-text "Enable tooltips"
1549 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1550
704a1de4 1551 (toolbar-append
1552 toolbar "Disable"
560af5c5 1553 :tooltip-text "Disable tooltips"
1554 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1555
704a1de4 1556 (toolbar-append toolbar :space)
560af5c5 1557
704a1de4 1558;; (toolbar-append-item
1559;; toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1560;; :tooltip-text "Show borders"
1561;; :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
560af5c5 1562
704a1de4 1563;; (toolbar-append-item
1564;; toolbar
1565;; "Borderless" (pixmap-new "clg:examples;test.xpm")
1566;; :tooltip-text "Hide borders"
1567;; :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1568
1569;; (toolbar-append toolbar :space)
1570
1571;; (toolbar-append-item
1572;; toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1573;; :tooltip-text "Empty spaces"
1574;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1575
1576;; (toolbar-append-item
1577;; toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1578;; :tooltip-text "Lines in spaces"
1579;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
196fe1e9 1580
704a1de4 1581 ))
560af5c5 1582
1583
1584
1585;;; Tooltips test
1586
704a1de4 1587;; (define-standard-dialog create-tooltips "Tooltips"
1588;; (setf
1589;; (window-allow-grow-p window) t
1590;; (window-allow-shrink-p window) nil
1591;; (window-auto-shrink-p window) t
1592;; (widget-width window) 200
1593;; (container-border-width main-box) 10
1594;; (box-spacing main-box) 10)
1595
1596;; (let ((tooltips (tooltips-new)))
1597;; (flet ((create-button (label tip-text tip-private)
1598;; (let ((button (make-instance 'toggle-button
1599;; :label label :parent main-box)))
1600;; (tooltips-set-tip tooltips button tip-text tip-private)
1601;; button)))
1602;; (create-button "button1" "This is button 1" "ContextHelp/button/1")
1603;; (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")
1604
1605;; (let* ((toggle (create-button "Override TipSQuery Label"
1606;; "Toggle TipsQuery view" "Hi msw! ;)"))
1607;; (box (make-instance 'v-box
1608;; :homogeneous nil :spacing 5 :border-width 5
1609;; :parent (make-instance 'frame
1610;; :label "ToolTips Inspector"
1611;; :label-xalign 0.5 :border-width 0
1612;; :parent main-box)))
1613;; (button (make-instance 'button :label "[?]" :parent box))
1614;; (tips-query (make-instance 'tips-query
1615;; :caller button :parent box)))
1616
1617;; (signal-connect
1618;; button 'clicked #'tips-query-start-query :object tips-query)
560af5c5 1619
704a1de4 1620;; (signal-connect
1621;; tips-query 'widget-entered
1622;; #'(lambda (widget tip-text tip-private)
1623;; (declare (ignore widget tip-private))
1624;; (when (toggle-button-active-p toggle)
1625;; (setf
1626;; (label-label tips-query)
1627;; (if tip-text
1628;; "There is a Tip!"
1629;; "There is no Tip!"))
1630;; (signal-emit-stop tips-query 'widget-entered))))
560af5c5 1631
704a1de4 1632;; (signal-connect
1633;; tips-query 'widget-selected
1634;; #'(lambda (widget tip-text tip-private event)
1635;; (declare (ignore tip-text event))
1636;; (when widget
1637;; (format
1638;; t "Help ~S requested for ~S~%"
1639;; (or tip-private "None") (type-of widget)))
1640;; t))
1641
1642;; (tooltips-set-tip
1643;; tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1644;; (tooltips-set-tip
1645;; tooltips close-button "Push this button to close window"
1646;; "ContextHelp/buttons/Close")))))
560af5c5 1647
1648
1649
560af5c5 1650;;; Main window
1651
1652(defun create-main-window ()
704a1de4 1653;; (rc-parse "clg:examples;testgtkrc2")
1654;; (rc-parse "clg:examples;testgtkrc")
196fe1e9 1655
1656 (let* ((button-specs
560af5c5 1657 '(("button box" create-button-box)
704a1de4 1658 ("buttons" create-buttons)
1659 ("calendar" create-calendar)
1660 ("check buttons" create-check-buttons)
704a1de4 1661 ("color selection" create-color-selection)
704a1de4 1662;; ("cursors" #|create-cursors|#)
1663 ("dialog" create-dialog)
1664;; ; ("dnd")
1665 ("entry" create-entry)
1666;; ("event watcher")
1667 ("file chooser" create-file-chooser)
1668;; ("font selection")
1669;; ("handle box" create-handle-box)
1670 ("image" create-image)
1671;; ("item factory")
1672 ("labels" create-labels)
1673 ("layout" create-layout)
21f6214a 1674 ("list" create-list)
560af5c5 1675 ("menus" create-menus)
704a1de4 1676;; ("modal window")
1677 ("notebook" create-notebook)
1678 ("panes" create-panes)
704a1de4 1679;; ("progress bar" #|create-progress-bar|#)
1680 ("radio buttons" create-radio-buttons)
1681 ("range controls" create-range-controls)
1682;; ("rc file")
1683 ("reparent" create-reparent)
1684 ("rulers" create-rulers)
1685;; ("saved position")
1686 ("scrolled windows" create-scrolled-windows)
1687;; ("shapes" create-shapes)
1688 ("spinbutton" create-spins)
c775862e 1689 ("statusbar" create-statusbar)
704a1de4 1690;; ("test idle" create-idle-test)
1691;; ("test mainloop")
1692;; ("test scrolling")
1693;; ("test selection")
1694;; ("test timeout" create-timeout-test)
1695;; ("text" #|create-text|#)
1696 ("toggle buttons" create-toggle-buttons)
1697 ("toolbar" create-toolbar)
1698;; ("tooltips" create-tooltips)
1699;; ("tree" #|create-tree|#)
1700))
1701 (main-window (make-instance 'window
1702 :title "testgtk.lisp" :name "main_window"
1703 :default-width 200 :default-height 400
1704 :allow-grow t :allow-shrink nil))
1705 (scrolled-window (make-instance 'scrolled-window
1706 :hscrollbar-policy :automatic
1707 :vscrollbar-policy :automatic
1708 :border-width 10))
1709 (close-button (make-instance 'button
1710 :label "close" :can-default t
1711 :signal (list 'clicked #'widget-destroy
1712 :object main-window))))
560af5c5 1713
1714 ;; Main box
704a1de4 1715 (make-instance 'v-box
560af5c5 1716 :parent main-window
704a1de4 1717 :child-args '(:expand nil)
1718 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1719 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1720 :child (list scrolled-window :expand t)
1721 :child (make-instance 'h-separator)
1722 :child (make-instance 'v-box
1723 :homogeneous nil :spacing 10 :border-width 10
1724 :child close-button))
1725
1726 (let ((content-box
1727 (make-instance 'v-box
1728 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1729 :children (mapcar #'(lambda (spec)
1730 (apply #'create-button spec))
1731 button-specs))))
1732 (scrolled-window-add-with-viewport scrolled-window content-box))
560af5c5 1733
704a1de4 1734 (widget-grab-focus close-button)
560af5c5 1735 (widget-show-all main-window)
1736 main-window))
1737
704a1de4 1738(clg-init)
1739(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).