chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Added selection in list test
[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
d975a970 18;; $Id: testgtk.lisp,v 1.7 2004-11-21 17:58:28 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)
d975a970 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)))
560af5c5 723
21f6214a 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))
d975a970 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))))
560af5c5 805
806
807;; Menus
808
809(defun create-menu (depth tearoff)
810 (unless (zerop depth)
704a1de4 811 (let ((menu (make-instance 'menu)))
560af5c5 812 (when tearoff
704a1de4 813 (let ((menu-item (make-instance 'tearoff-menu-item)))
814 (menu-shell-append menu menu-item)))
560af5c5 815 (let ((group nil))
816 (dotimes (i 5)
704a1de4 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))
560af5c5 823 (unless (zerop (mod depth 2))
704a1de4 824 (setf (check-menu-item-active-p menu-item) t))
825 (menu-shell-append menu menu-item)
560af5c5 826 (when (= i 3)
704a1de4 827 (setf (widget-sensitive-p menu-item) nil))
828 (setf (menu-item-submenu menu-item) (create-menu (1- depth) t)))))
196fe1e9 829 menu)))
560af5c5 830
831
704a1de4 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
613fb570 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))))
560af5c5 859
613fb570 860 (widget-show-all main)))
560af5c5 861
862
863;;; Notebook
864
704a1de4 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))))
560af5c5 917
560af5c5 918
704a1de4 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))
613fb570 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)))
704a1de4 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)))
560af5c5 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))
560af5c5 1033 (container-remove paned child)
1034 (if is-child1-p
1035 (paned-pack1 paned child (not resize) shrink)
196fe1e9 1036 (paned-pack2 paned child (not resize) shrink)))))
560af5c5 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))
560af5c5 1045 (container-remove paned child)
1046 (if is-child1-p
1047 (paned-pack1 paned child resize (not shrink))
196fe1e9 1048 (paned-pack2 paned child resize (not shrink))))))
560af5c5 1049
1050(defun create-pane-options (paned frame-label label1 label2)
704a1de4 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)))
560af5c5 1054
613fb570 1055 (table-attach table (create-label label1) 0 1 0 1)
704a1de4 1056 (let ((check-button (make-instance 'check-button :label "Resize")))
560af5c5 1057 (table-attach table check-button 0 1 1 2)
1058 (signal-connect
1059 check-button 'toggled #'toggle-resize :object (paned-child1 paned)))
704a1de4 1060 (let ((check-button (make-instance 'check-button :label "Shrink")))
560af5c5 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
613fb570 1066 (table-attach table (create-label label2) 1 2 0 1)
704a1de4 1067 (let ((check-button (make-instance 'check-button :label "Resize")))
560af5c5 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)))
704a1de4 1072 (let ((check-button (make-instance 'check-button :label "Shrink")))
560af5c5 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)))
560af5c5 1077 frame))
1078
704a1de4 1079(define-toplevel create-panes (window "Panes")
1080 (let* ((hpaned (make-instance 'h-paned
196fe1e9 1081 :child1 (make-instance 'frame
704a1de4 1082 :width-request 60 :height-request 60
1083 :shadow-type :in
613fb570 1084 :child (make-instance 'buttun :label "Hi there"))
704a1de4 1085 :child2 (make-instance 'frame
1086 :width-request 80 :height-request 60
1087 :shadow-type :in)))
1088 (vpaned (make-instance 'v-paned
196fe1e9 1089 :border-width 5
1090 :child1 hpaned
1091 :child2 (make-instance 'frame
704a1de4 1092 :width-request 80 :height-request 60
1093 :shadow-type :in))))
196fe1e9 1094
704a1de4 1095 (make-instance 'v-box
196fe1e9 1096 :parent window
704a1de4 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"))))
560af5c5 1101
1102
560af5c5 1103;;; Progress bar
1104
196fe1e9 1105
560af5c5 1106
1107
1108;;; Radio buttons
1109
704a1de4 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)))
560af5c5 1114
1115
1116;;; Rangle controls
1117
704a1de4 1118(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1119 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 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))))
560af5c5 1127
1128
1129;;; Reparent test
1130
704a1de4 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")))
560af5c5 1135
704a1de4 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)))
560af5c5 1146
704a1de4 1147 (box-pack-start (create-frame "Frame 1") label nil t 0)
1148 (create-frame "Frame 2"))
1149 (widget-show-all main)))
560af5c5 1150
1151
1152;;; Rulers
1153
704a1de4 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)
196fe1e9 1168 (table-attach table ruler 1 2 0 1 :y-options '(:fill)))
704a1de4 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)
196fe1e9 1173 (table-attach table ruler 0 1 1 2 :x-options '(:fill)))))
560af5c5 1174
1175
1176
1177;;; Scrolled window
1178
704a1de4 1179(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1180 :default-width 300
1181 :default-height 300)
196fe1e9 1182 (let* ((scrolled-window
1183 (make-instance 'scrolled-window
704a1de4 1184 :parent dialog :border-width 10
1185 :vscrollbar-policy :automatic
196fe1e9 1186 :hscrollbar-policy :automatic))
1187 (table
1188 (make-instance 'table
704a1de4 1189 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1190 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1191 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1192
560af5c5 1193 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1194 (dotimes (i 20)
1195 (dotimes (j 20)
1196 (let ((button
704a1de4 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)))
560af5c5 1201
1202
1203;;; Shapes
1204
704a1de4 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)))
196fe1e9 1213
704a1de4 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)
196fe1e9 1222
704a1de4 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))
560af5c5 1241
704a1de4 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)))
560af5c5 1252
704a1de4 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)))))
560af5c5 1285
1286
1287
1288;;; Spin buttons
1289
704a1de4 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 : "
c775862e 1310 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
704a1de4 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)))
560af5c5 1386
704a1de4 1387
c775862e 1388;;; Statusbar
560af5c5 1389
c775862e 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)))
560af5c5 1424
1425
1426;;; Idle test
1427
704a1de4 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))))
560af5c5 1437
704a1de4 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))))))))
560af5c5 1465
704a1de4 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))))))))
560af5c5 1476
1477
1478
1479;;; Timeout test
1480
704a1de4 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))))
196fe1e9 1489
704a1de4 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))))))))
560af5c5 1517
1518
560af5c5 1519;;; Toggle buttons
1520
704a1de4 1521(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1522 (make-instance 'v-box
1523 :border-width 10 :spacing 10 :parent dialog :show-all t
1524 :children (loop
1525 for n from 1 to 3
1526 collect (make-instance 'toggle-button
1527 :label (format nil "Button~D" (1+ n))))))
560af5c5 1528
1529
1530
1531;;; Toolbar test
1532
704a1de4 1533;; TODO: style properties
1534(define-toplevel create-toolbar (window "Toolbar test" :resizable nil)
1535 (let ((toolbar (make-instance 'toolbar :parent window)))
1536; (setf (toolbar-relief toolbar) :none)
560af5c5 1537
704a1de4 1538 ;; Insert a stock item
1539 (toolbar-append toolbar "gtk-quit"
1540 :tooltip-text "Destroy toolbar"
1541 :tooltip-private-text "Toolbar/Quit"
1542 :callback #'(lambda () (widget-destroy window)))
560af5c5 1543
704a1de4 1544 ;; Image widge as icon
1545 (toolbar-append toolbar "Horizontal"
1546 :icon (make-instance 'image :file #p"clg:examples;test.xpm")
560af5c5 1547 :tooltip-text "Horizontal toolbar layout"
1548 :tooltip-private-text "Toolbar/Horizontal"
1549 :callback #'(lambda () (setf (toolbar-orientation toolbar) :horizontal)))
1550
704a1de4 1551 ;; Icon from file
1552 (toolbar-append toolbar "Vertical"
1553 :icon #p"clg:examples;test.xpm"
560af5c5 1554 :tooltip-text "Vertical toolbar layout"
1555 :tooltip-private-text "Toolbar/Vertical"
1556 :callback #'(lambda () (setf (toolbar-orientation toolbar) :vertical)))
1557
704a1de4 1558 (toolbar-append toolbar :space)
560af5c5 1559
704a1de4 1560 ;; Stock icon
1561 (toolbar-append toolbar "Icons"
1562 :icon "gtk-execute"
560af5c5 1563 :tooltip-text "Only show toolbar icons"
1564 :tooltip-private-text "Toolbar/IconsOnly"
1565 :callback #'(lambda () (setf (toolbar-style toolbar) :icons)))
1566
704a1de4 1567 ;; Icon from pixmap data
1568 (toolbar-append toolbar "Text"
1569 :icon gtk-mini-xpm
560af5c5 1570 :tooltip-text "Only show toolbar text"
1571 :tooltip-private-text "Toolbar/TextOnly"
1572 :callback #'(lambda () (setf (toolbar-style toolbar) :text)))
1573
704a1de4 1574 (toolbar-append toolbar "Both"
560af5c5 1575 :tooltip-text "Show toolbar icons and text"
1576 :tooltip-private-text "Toolbar/Both"
1577 :callback #'(lambda () (setf (toolbar-style toolbar) :both)))
1578
704a1de4 1579 (toolbar-append toolbar :space)
560af5c5 1580
704a1de4 1581 (toolbar-append toolbar (make-instance 'entry)
1582 :tooltip-text "This is an unusable GtkEntry"
560af5c5 1583 :tooltip-private-text "Hey don't click me!")
1584
704a1de4 1585 (toolbar-append toolbar :space)
560af5c5 1586
704a1de4 1587;; (toolbar-append-item
1588;; toolbar "Small" ;(pixmap-new "clg:examples;test.xpm")
1589;; :tooltip-text "Use small spaces"
1590;; :tooltip-private-text "Toolbar/Small"
1591;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 5)))
560af5c5 1592
704a1de4 1593;; (toolbar-append-item
1594;; toolbar "Big" ;(pixmap-new "clg:examples;test.xpm")
1595;; :tooltip-text "Use big spaces"
1596;; :tooltip-private-text "Toolbar/Big"
1597;; :callback #'(lambda () (setf (toolbar-space-size toolbar) 10)))
560af5c5 1598
704a1de4 1599;; (toolbar-append toolbar :space)
560af5c5 1600
704a1de4 1601 (toolbar-append
1602 toolbar "Enable"
560af5c5 1603 :tooltip-text "Enable tooltips"
1604 :callback #'(lambda () (toolbar-enable-tooltips toolbar)))
1605
704a1de4 1606 (toolbar-append
1607 toolbar "Disable"
560af5c5 1608 :tooltip-text "Disable tooltips"
1609 :callback #'(lambda () (toolbar-disable-tooltips toolbar)))
1610
704a1de4 1611 (toolbar-append toolbar :space)
560af5c5 1612
704a1de4 1613;; (toolbar-append-item
1614;; toolbar "Borders" (pixmap-new "clg:examples;test.xpm")
1615;; :tooltip-text "Show borders"
1616;; :callback #'(lambda () (setf (toolbar-relief toolbar) :normal)))
560af5c5 1617
704a1de4 1618;; (toolbar-append-item
1619;; toolbar
1620;; "Borderless" (pixmap-new "clg:examples;test.xpm")
1621;; :tooltip-text "Hide borders"
1622;; :callback #'(lambda () (setf (toolbar-relief toolbar) :none)))
1623
1624;; (toolbar-append toolbar :space)
1625
1626;; (toolbar-append-item
1627;; toolbar "Empty" (pixmap-new "clg:examples;test.xpm")
1628;; :tooltip-text "Empty spaces"
1629;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :empty)))
1630
1631;; (toolbar-append-item
1632;; toolbar "Lines" (pixmap-new "clg:examples;test.xpm")
1633;; :tooltip-text "Lines in spaces"
1634;; :callback #'(lambda () (setf (toolbar-space-style toolbar) :line)))
196fe1e9 1635
704a1de4 1636 ))
560af5c5 1637
1638
1639
1640;;; Tooltips test
1641
704a1de4 1642;; (define-standard-dialog create-tooltips "Tooltips"
1643;; (setf
1644;; (window-allow-grow-p window) t
1645;; (window-allow-shrink-p window) nil
1646;; (window-auto-shrink-p window) t
1647;; (widget-width window) 200
1648;; (container-border-width main-box) 10
1649;; (box-spacing main-box) 10)
1650
1651;; (let ((tooltips (tooltips-new)))
1652;; (flet ((create-button (label tip-text tip-private)
1653;; (let ((button (make-instance 'toggle-button
1654;; :label label :parent main-box)))
1655;; (tooltips-set-tip tooltips button tip-text tip-private)
1656;; button)))
1657;; (create-button "button1" "This is button 1" "ContextHelp/button/1")
1658;; (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")
1659
1660;; (let* ((toggle (create-button "Override TipSQuery Label"
1661;; "Toggle TipsQuery view" "Hi msw! ;)"))
1662;; (box (make-instance 'v-box
1663;; :homogeneous nil :spacing 5 :border-width 5
1664;; :parent (make-instance 'frame
1665;; :label "ToolTips Inspector"
1666;; :label-xalign 0.5 :border-width 0
1667;; :parent main-box)))
1668;; (button (make-instance 'button :label "[?]" :parent box))
1669;; (tips-query (make-instance 'tips-query
1670;; :caller button :parent box)))
1671
1672;; (signal-connect
1673;; button 'clicked #'tips-query-start-query :object tips-query)
560af5c5 1674
704a1de4 1675;; (signal-connect
1676;; tips-query 'widget-entered
1677;; #'(lambda (widget tip-text tip-private)
1678;; (declare (ignore widget tip-private))
1679;; (when (toggle-button-active-p toggle)
1680;; (setf
1681;; (label-label tips-query)
1682;; (if tip-text
1683;; "There is a Tip!"
1684;; "There is no Tip!"))
1685;; (signal-emit-stop tips-query 'widget-entered))))
560af5c5 1686
704a1de4 1687;; (signal-connect
1688;; tips-query 'widget-selected
1689;; #'(lambda (widget tip-text tip-private event)
1690;; (declare (ignore tip-text event))
1691;; (when widget
1692;; (format
1693;; t "Help ~S requested for ~S~%"
1694;; (or tip-private "None") (type-of widget)))
1695;; t))
1696
1697;; (tooltips-set-tip
1698;; tooltips button "Start the Tooltip Inspector" "ContextHelp/buttons/?")
1699;; (tooltips-set-tip
1700;; tooltips close-button "Push this button to close window"
1701;; "ContextHelp/buttons/Close")))))
560af5c5 1702
1703
1704
560af5c5 1705;;; Main window
1706
1707(defun create-main-window ()
704a1de4 1708;; (rc-parse "clg:examples;testgtkrc2")
1709;; (rc-parse "clg:examples;testgtkrc")
196fe1e9 1710
1711 (let* ((button-specs
560af5c5 1712 '(("button box" create-button-box)
704a1de4 1713 ("buttons" create-buttons)
1714 ("calendar" create-calendar)
1715 ("check buttons" create-check-buttons)
704a1de4 1716 ("color selection" create-color-selection)
704a1de4 1717;; ("cursors" #|create-cursors|#)
1718 ("dialog" create-dialog)
1719;; ; ("dnd")
1720 ("entry" create-entry)
1721;; ("event watcher")
1722 ("file chooser" create-file-chooser)
1723;; ("font selection")
1724;; ("handle box" create-handle-box)
1725 ("image" create-image)
1726;; ("item factory")
1727 ("labels" create-labels)
1728 ("layout" create-layout)
21f6214a 1729 ("list" create-list)
560af5c5 1730 ("menus" create-menus)
704a1de4 1731;; ("modal window")
1732 ("notebook" create-notebook)
1733 ("panes" create-panes)
704a1de4 1734;; ("progress bar" #|create-progress-bar|#)
1735 ("radio buttons" create-radio-buttons)
1736 ("range controls" create-range-controls)
1737;; ("rc file")
1738 ("reparent" create-reparent)
1739 ("rulers" create-rulers)
1740;; ("saved position")
1741 ("scrolled windows" create-scrolled-windows)
1742;; ("shapes" create-shapes)
1743 ("spinbutton" create-spins)
c775862e 1744 ("statusbar" create-statusbar)
704a1de4 1745;; ("test idle" create-idle-test)
1746;; ("test mainloop")
1747;; ("test scrolling")
1748;; ("test selection")
1749;; ("test timeout" create-timeout-test)
1750;; ("text" #|create-text|#)
1751 ("toggle buttons" create-toggle-buttons)
1752 ("toolbar" create-toolbar)
1753;; ("tooltips" create-tooltips)
1754;; ("tree" #|create-tree|#)
1755))
1756 (main-window (make-instance 'window
1757 :title "testgtk.lisp" :name "main_window"
1758 :default-width 200 :default-height 400
1759 :allow-grow t :allow-shrink nil))
1760 (scrolled-window (make-instance 'scrolled-window
1761 :hscrollbar-policy :automatic
1762 :vscrollbar-policy :automatic
1763 :border-width 10))
1764 (close-button (make-instance 'button
1765 :label "close" :can-default t
1766 :signal (list 'clicked #'widget-destroy
1767 :object main-window))))
560af5c5 1768
1769 ;; Main box
704a1de4 1770 (make-instance 'v-box
560af5c5 1771 :parent main-window
704a1de4 1772 :child-args '(:expand nil)
1773 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1774 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1775 :child (list scrolled-window :expand t)
1776 :child (make-instance 'h-separator)
1777 :child (make-instance 'v-box
1778 :homogeneous nil :spacing 10 :border-width 10
1779 :child close-button))
1780
1781 (let ((content-box
1782 (make-instance 'v-box
1783 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1784 :children (mapcar #'(lambda (spec)
1785 (apply #'create-button spec))
1786 button-specs))))
1787 (scrolled-window-add-with-viewport scrolled-window content-box))
560af5c5 1788
704a1de4 1789 (widget-grab-focus close-button)
560af5c5 1790 (widget-show-all main-window)
1791 main-window))
1792
704a1de4 1793(clg-init)
1794(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).