chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Added font selection
[clg] / examples / testgtk.lisp
CommitLineData
560af5c5 1;; Common Lisp bindings for GTK+ v2.0
787721b6 2;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
560af5c5 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
3f315085 18;; $Id: testgtk.lisp,v 1.21 2005-02-27 13:28:19 espen Exp $
560af5c5 19
704a1de4 20
21;(use-package "GTK")
22(in-package "GTK")
23
24(defmacro define-toplevel (name (window title &rest initargs) &body body)
25 `(let ((,window nil))
560af5c5 26 (defun ,name ()
704a1de4 27 (unless ,window
f6ebddea 28 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
704a1de4 29 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
560af5c5 30 ,@body)
31
704a1de4 32 (if (not (widget-visible-p ,window))
f6ebddea 33 (widget-show ,window)
704a1de4 34 (widget-hide ,window)))))
35
560af5c5 36
704a1de4 37(defmacro define-dialog (name (dialog title &optional (class 'dialog)
38 &rest initargs)
39 &body body)
40 `(let ((,dialog nil))
560af5c5 41 (defun ,name ()
704a1de4 42 (unless ,dialog
f6ebddea 43 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
704a1de4 44 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
45 ,@body)
560af5c5 46
704a1de4 47 (if (not (widget-visible-p ,dialog))
48 (widget-show ,dialog)
49 (widget-hide ,dialog)))))
560af5c5 50
51
704a1de4 52(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
53 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
bdc1babf 54 ,@body
55 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
560af5c5 56
57
560af5c5 58
59;;; Pixmaps used in some of the tests
60
61(defvar gtk-mini-xpm
196fe1e9 62 #("15 20 17 1"
560af5c5 63 " c None"
64 ". c #14121F"
65 "+ c #278828"
66 "@ c #9B3334"
67 "# c #284C72"
68 "$ c #24692A"
69 "% c #69282E"
70 "& c #37C539"
71 "* c #1D2F4D"
72 "= c #6D7076"
73 "- c #7D8482"
74 "; c #E24A49"
75 "> c #515357"
76 ", c #9B9C9B"
77 "' c #2FA232"
78 ") c #3CE23D"
79 "! c #3B6CCB"
80 " "
81 " ***> "
82 " >.*!!!* "
83 " ***....#*= "
84 " *!*.!!!**!!# "
85 " .!!#*!#*!!!!# "
86 " @%#!.##.*!!$& "
87 " @;%*!*.#!#')) "
88 " @;;@%!!*$&)'' "
89 " @%.%@%$'&)$+' "
90 " @;...@$'*'*)+ "
91 " @;%..@$+*.')$ "
92 " @;%%;;$+..$)# "
93 " @;%%;@$$$'.$# "
94 " %;@@;;$$+))&* "
95 " %;;;@+$&)&* "
96 " %;;@'))+> "
97 " %;@'&# "
98 " >%$$ "
99 " >= "))
100
101(defvar book-closed-xpm
196fe1e9 102 #("16 16 6 1"
560af5c5 103 " c None s None"
104 ". c black"
105 "X c red"
106 "o c yellow"
107 "O c #808080"
108 "# c white"
109 " "
110 " .. "
111 " ..XX. "
112 " ..XXXXX. "
113 " ..XXXXXXXX. "
114 ".ooXXXXXXXXX. "
115 "..ooXXXXXXXXX. "
116 ".X.ooXXXXXXXXX. "
117 ".XX.ooXXXXXX.. "
118 " .XX.ooXXX..#O "
119 " .XX.oo..##OO. "
120 " .XX..##OO.. "
121 " .X.#OO.. "
122 " ..O.. "
123 " .. "
124 " "))
125
126(defvar mini-page-xpm
196fe1e9 127 #("16 16 4 1"
560af5c5 128 " c None s None"
129 ". c black"
130 "X c white"
131 "o c #808080"
132 " "
133 " ....... "
134 " .XXXXX.. "
135 " .XoooX.X. "
136 " .XXXXX.... "
137 " .XooooXoo.o "
138 " .XXXXXXXX.o "
139 " .XooooooX.o "
140 " .XXXXXXXX.o "
141 " .XooooooX.o "
142 " .XXXXXXXX.o "
143 " .XooooooX.o "
144 " .XXXXXXXX.o "
145 " ..........o "
146 " oooooooooo "
147 " "))
148
149(defvar book-open-xpm
196fe1e9 150 #("16 16 4 1"
560af5c5 151 " c None s None"
152 ". c black"
153 "X c #808080"
154 "o c white"
155 " "
156 " .. "
157 " .Xo. ... "
158 " .Xoo. ..oo. "
159 " .Xooo.Xooo... "
160 " .Xooo.oooo.X. "
161 " .Xooo.Xooo.X. "
162 " .Xooo.oooo.X. "
163 " .Xooo.Xooo.X. "
164 " .Xooo.oooo.X. "
165 " .Xoo.Xoo..X. "
166 " .Xo.o..ooX. "
167 " .X..XXXXX. "
168 " ..X....... "
169 " .. "
170 " "))
171
172
173
174;;; Button box
175
196fe1e9 176(defun create-bbox-in-frame (class frame-label spacing width height layout)
704a1de4 177 (declare (ignore width height))
178 (make-instance 'frame
179 :label frame-label
180 :child (make-instance class
181 :border-width 5 :layout-style layout :spacing spacing
977a550d 182 :child (make-instance 'button :stock "gtk-ok")
183 :child (make-instance 'button :stock "gtk-cancel")
184 :child (make-instance 'button :stock "gtk-help"))))
704a1de4 185
186(define-toplevel create-button-box (window "Button Boxes")
187 (make-instance 'v-box
f6ebddea 188 :parent window :border-width 10 :spacing 10
704a1de4 189 :child (make-instance 'frame
190 :label "Horizontal Button Boxes"
191 :child (make-instance 'v-box
192 :border-width 10 :spacing 10
193 :children (mapcar
194 #'(lambda (args)
195 (apply #'create-bbox-in-frame
196 'h-button-box args))
197 '(("Spread" 40 85 20 :spread)
198 ("Edge" 40 85 20 :edge)
199 ("Start" 40 85 20 :start)
200 ("End" 40 85 20 :end)))))
201 :child (make-instance 'frame
202 :label "Vertical Button Boxes"
203 :child (make-instance 'h-box
204 :border-width 10 :spacing 10
205 :children (mapcar
206 #'(lambda (args)
207 (apply #'create-bbox-in-frame
208 'v-button-box args))
209 '(("Spread" 30 85 20 :spread)
210 ("Edge" 30 85 20 :edge)
211 ("Start" 30 85 20 :start)
212 ("End" 30 85 20 :end)))))))
196fe1e9 213
214
215;; Buttons
216
704a1de4 217(define-simple-dialog create-buttons (dialog "Buttons")
196fe1e9 218 (let ((table (make-instance 'table
704a1de4 219 :n-rows 3 :n-columns 3 :homogeneous nil
196fe1e9 220 :row-spacing 5 :column-spacing 5 :border-width 10
704a1de4 221 :parent dialog))
222 (buttons (loop
223 for n from 1 to 10
224 collect (make-instance 'button
225 :label (format nil "button~D" (1+ n))))))
226
196fe1e9 227 (dotimes (column 3)
228 (dotimes (row 3)
704a1de4 229 (let ((button (nth (+ (* 3 row) column) buttons))
230 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
196fe1e9 231 (signal-connect button 'clicked
232 #'(lambda ()
233 (if (widget-visible-p button+1)
234 (widget-hide button+1)
235 (widget-show button+1))))
33f468b7 236 (table-attach table button column (1+ column) row (1+ row)
f6ebddea 237 :options '(:expand :fill)))))))
560af5c5 238
239
240;; Calenadar
241
704a1de4 242(define-simple-dialog create-calendar (dialog "Calendar")
243 (make-instance 'v-box
f6ebddea 244 :parent dialog :border-width 10
704a1de4 245 :child (make-instance 'calendar)))
560af5c5 246
247
248;;; Check buttons
249
704a1de4 250(define-simple-dialog create-check-buttons (dialog "Check Buttons")
251 (make-instance 'v-box
f6ebddea 252 :border-width 10 :spacing 10 :parent dialog
704a1de4 253 :children (loop
254 for n from 1 to 3
255 collect (make-instance 'check-button
256 :label (format nil "Button~D" n)))))
560af5c5 257
258
259
260;;; Color selection
261
704a1de4 262(define-dialog create-color-selection (dialog "Color selection dialog"
263 'color-selection-dialog
f6ebddea 264 :allow-grow nil :allow-shrink nil
265 :show-children nil)
266 (with-slots (colorsel) dialog
267 (let ((button (make-instance 'check-button :label "Show Opacity")))
268 (dialog-add-action-widget dialog button
269 #'(lambda ()
270 (setf
271 (color-selection-has-opacity-control-p colorsel)
272 (toggle-button-active-p button)))))
273
274 (let ((button (make-instance 'check-button :label "Show Palette")))
275 (dialog-add-action-widget dialog button
276 #'(lambda ()
277 (setf
278 (color-selection-has-palette-p colorsel)
279 (toggle-button-active-p button)))))
704a1de4 280
281 (signal-connect dialog :ok
282 #'(lambda ()
283 (let ((color (color-selection-current-color colorsel)))
284 (format t "Selected color: ~A~%" color)
285 (setf (color-selection-current-color colorsel) color)
286 (widget-hide dialog))))
560af5c5 287
704a1de4 288 (signal-connect dialog :cancel #'widget-destroy :object t)))
560af5c5 289
560af5c5 290
291;;; Cursors
292
293(defun clamp (n min-val max-val)
294 (declare (number n min-val max-val))
295 (max (min n max-val) min-val))
296
aa9ceddc 297(defun set-cursor (spinner drawing-area label)
298 (let ((cursor
299 (glib:int-enum
300 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
301 'gdk:cursor-type)))
302 (setf (label-label label) (string-downcase cursor))
303 (setf (widget-cursor drawing-area) cursor)))
304
305(defun cursor-expose (drawing-area event)
306 (declare (ignore event))
307 (multiple-value-bind (width height)
977a550d 308 (widget-get-size-allocation drawing-area)
aa9ceddc 309 (let* ((window (widget-window drawing-area))
310 (style (widget-style drawing-area))
311 (white-gc (style-white-gc style))
312 (gray-gc (style-bg-gc style :normal))
313 (black-gc (style-black-gc style)))
314 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
315 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
316 (floor height 2))
317 (gdk:draw-rectangle window gray-gc t (floor width 3)
318 (floor height 3) (floor width 3)
319 (floor height 3))))
320 t)
321
322(define-simple-dialog create-cursors (dialog "Cursors")
323 (let ((spinner (make-instance 'spin-button
324 :adjustment (adjustment-new
325 0 0
326 (1- (enum-int :last-cursor 'gdk:cursor-type))
327 2 10 0)))
328 (drawing-area (make-instance 'drawing-area
329 :width-request 80 :height-request 80
4280ef98 330 :events '(:exposure :button-press)))
aa9ceddc 331 (label (make-instance 'label :label "XXX")))
332
333 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
334
335 (signal-connect drawing-area 'button-press-event
336 #'(lambda (event)
337 (case (gdk:event-button event)
510fbcc1 338 (1 (spin-button-spin spinner :step-forward))
339 (3 (spin-button-spin spinner :step-backward)))
aa9ceddc 340 t))
560af5c5 341
aa9ceddc 342 (signal-connect drawing-area 'scroll-event
343 #'(lambda (event)
344 (case (gdk:event-direction event)
510fbcc1 345 (:up (spin-button-spin spinner :step-forward))
346 (:down (spin-button-spin spinner :step-backward)))
aa9ceddc 347 t))
560af5c5 348
aa9ceddc 349 (signal-connect spinner 'changed
350 #'(lambda ()
351 (set-cursor spinner drawing-area label)))
560af5c5 352
aa9ceddc 353 (make-instance 'v-box
f6ebddea 354 :parent dialog :border-width 10 :spacing 5
aa9ceddc 355 :child (list
356 (make-instance 'h-box
357 :border-width 5
358 :child (list
359 (make-instance 'label :label "Cursor Value : ")
360 :expand nil)
361 :child spinner)
362 :expand nil)
363 :child (make-instance 'frame
aa9ceddc 364 :label "Cursor Area" :label-xalign 0.5 :border-width 10
365 :child drawing-area)
366 :child (list label :expand nil))
367
368 (widget-realize drawing-area)
369 (set-cursor spinner drawing-area label)))
560af5c5 370
371
372;;; Dialog
373
704a1de4 374(let ((dialog nil))
375 (defun create-dialog ()
376 (unless dialog
377 (setq dialog (make-instance 'dialog
378 :title "Dialog" :default-width 200
379 :button "Toggle"
380 :button (list "gtk-ok" #'widget-destroy :object t)
381 :signal (list 'destroy
382 #'(lambda ()
383 (setq dialog nil)))))
384
385 (let ((label (make-instance 'label
386 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
387 :parent dialog)))
388 (signal-connect dialog "Toggle"
389 #'(lambda ()
390 (if (widget-visible-p label)
391 (widget-hide label)
392 (widget-show label))))))
560af5c5 393
704a1de4 394 (if (widget-visible-p dialog)
395 (widget-hide dialog)
396 (widget-show dialog))))
560af5c5 397
398
399;; Entry
400
704a1de4 401(define-simple-dialog create-entry (dialog "Entry")
402 (let ((main (make-instance 'v-box
403 :border-width 10 :spacing 10 :parent dialog)))
196fe1e9 404
704a1de4 405 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
406 (editable-select-region entry 0 5) ; this has no effect when
407 ; entry is editable
408;; (editable-insert-text entry "great " 6)
409;; (editable-delete-text entry 6 12)
196fe1e9 410
613fb570 411 (let ((combo (make-instance 'combo-box-entry
704a1de4 412 :parent main
613fb570 413 :content '("item0"
414 "item1 item1"
415 "item2 item2 item2"
416 "item3 item3 item3 item3"
417 "item4 item4 item4 item4 item4"
418 "item5 item5 item5 item5 item5 item5"
419 "item6 item6 item6 item6 item6"
420 "item7 item7 item7 item7"
421 "item8 item8 item8"
422 "item9 item9"))))
423 (with-slots (child) combo
424 (setf (editable-text child) "hello world")
425 (editable-select-region child 0)))
704a1de4 426
427 (flet ((create-check-button (label slot)
428 (make-instance 'check-button
429 :label label :active t :parent main
430 :signal (list 'toggled
431 #'(lambda (button)
432 (setf (slot-value entry slot)
433 (toggle-button-active-p button)))
434 :object t))))
435
436 (create-check-button "Editable" 'editable)
437 (create-check-button "Visible" 'visibility)
f6ebddea 438 (create-check-button "Sensitive" 'sensitive)))))
560af5c5 439
560af5c5 440
96b68e83 441;; Expander
442
443(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
444 (make-instance 'v-box
f6ebddea 445 :parent dialog :spacing 5 :border-width 5
96b68e83 446 :child (create-label "Expander demo. Click on the triangle for details.")
447 :child (make-instance 'expander
448 :label "Details"
449 :child (create-label "Details can be shown or hidden."))))
450
560af5c5 451
704a1de4 452;; File chooser dialog
560af5c5 453
704a1de4 454(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
455 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
456 (dialog-add-button dialog "gtk-ok"
457 #'(lambda ()
842e5ffe 458 (if (slot-boundp dialog 'filename)
812dd869 459 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
460 (write-line "No files selected"))
704a1de4 461 (widget-destroy dialog))))
560af5c5 462
463
3f315085 464;; Font selection dialog
465
466(define-toplevel create-font-selection (window "Font Button" :resizable nil)
467 (make-instance 'h-box
468 :parent window :spacing 8 :border-width 8
469 :child (make-instance 'label :label "Pick a font")
470 :child (make-instance 'font-button
471 :use-font t :title "Font Selection Dialog")))
472
560af5c5 473
474;;; Handle box
475
842e5ffe 476(define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
477 (make-instance 'v-box
478 :parent window
479 :child (create-label "Above")
480 :child (make-instance 'h-separator)
481 :child (make-instance 'h-box
482 :spacing 10
483 :child (list
484 (make-instance 'handle-box
485 :child (create-toolbar window)
486 :signal (list 'child-attached
487 #'(lambda (child)
488 (format t "~A attached~%" child)))
489 :signal (list 'child-detached
490 #'(lambda (child)
491 (format t "~A detached~%" child))))
492 :expand nil :fill :nil))
493 :child (make-instance 'h-separator)
494 :child (create-label "Below")))
704a1de4 495
496;;; Image
560af5c5 497
704a1de4 498(define-toplevel create-image (window "Image")
499 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5 500
501
502;;; Labels
503
704a1de4 504(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9 505 (flet ((create-label-in-frame (frame-label label-text &rest args)
506 (list
507 (make-instance 'frame
508 :label frame-label
704a1de4 509 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
196fe1e9 510 :fill nil :expand nil)))
704a1de4 511 (make-instance 'h-box
512 :spacing 5 :parent window
513 :child-args '(:fill nil :expand nil)
514 :child (make-instance 'v-box
515 :spacing 5
516 :child (create-label-in-frame "Normal Label" "This is a Normal label")
517 :child (create-label-in-frame "Multi-line Label"
560af5c5 518"This is a Multi-line label.
519Second line
196fe1e9 520Third line")
704a1de4 521 :child (create-label-in-frame "Left Justified Label"
560af5c5 522"This is a Left-Justified
523Multi-line.
196fe1e9 524Third line"
704a1de4 525 :justify :left)
526 :child (create-label-in-frame "Right Justified Label"
560af5c5 527"This is a Right-Justified
528Multi-line.
196fe1e9 529Third line"
704a1de4 530 :justify :right))
531 :child (make-instance 'v-box
532 :spacing 5
533 :child (create-label-in-frame "Line wrapped label"
560af5c5 534"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 535 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4 536 :wrap t)
537
538 :child (create-label-in-frame "Filled, wrapped label"
560af5c5 539"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.
540 This is a new paragraph.
196fe1e9 541 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4 542 :justify :fill :wrap t)
543
544 :child (create-label-in-frame "Underlined label"
560af5c5 545"This label is underlined!
196fe1e9 546This one is underlined (こんにちは) in quite a funky fashion"
704a1de4 547 :justify :left
548 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
560af5c5 549
550
551;;; Layout
552
aa9ceddc 553(defun layout-expose (layout event)
554 (when (eq (gdk:event-window event) (layout-bin-window layout))
555 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
556 (let ((imin (truncate gdk:x 10))
557 (imax (truncate (+ gdk:x gdk:width 9) 10))
558 (jmin (truncate gdk:y 10))
559 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
560
561 (let ((window (layout-bin-window layout))
562 (gc (style-black-gc (widget-style layout))))
563 (loop
564 for i from imin below imax
565 do (loop
566 for j from jmin below jmax
567 unless (zerop (mod (+ i j) 2))
568 do (gdk:draw-rectangle
569 window gc t (* 10 i) (* 10 j)
570 (1+ (mod i 10)) (1+ (mod j 10)))))))))
571 nil)
704a1de4 572
573(define-toplevel create-layout (window "Layout" :default-width 200
574 :default-height 200)
196fe1e9 575 (let ((layout (make-instance 'layout
576 :parent (make-instance 'scrolled-window :parent window)
4280ef98 577 :width 1600 :height 128000 :events '(:exposure)
f6ebddea 578 :signal (list 'expose-event #'layout-expose :object t))))
196fe1e9 579
580 (with-slots (hadjustment vadjustment) layout
581 (setf
582 (adjustment-step-increment hadjustment) 10.0
583 (adjustment-step-increment vadjustment) 10.0))
560af5c5 584
585 (dotimes (i 16)
586 (dotimes (j 16)
704a1de4 587 (let ((text (format nil "Button ~D, ~D" i j)))
f6ebddea 588 (layout-put layout
589 (make-instance (if (not (zerop (mod (+ i j) 2)))
590 'button
591 'label)
592 :label text :visible t)
593 (* j 100) (* i 100)))))
560af5c5 594
704a1de4 595 (loop
596 for i from 16 below 1280
597 do (let ((text (format nil "Button ~D, ~D" i 0)))
f6ebddea 598 (layout-put layout
599 (make-instance (if (not (zerop (mod i 2)))
600 'button
601 'label)
602 :label text :visible t)
603 0 (* i 100))))))
196fe1e9 604
560af5c5 605
606
607;;; List
608
21f6214a 609(define-simple-dialog create-list (dialog "List" :default-height 400)
d975a970 610 (let* ((store (make-instance 'list-store
611 :column-types '(string int boolean)
612 :column-names '(:foo :bar :baz)
613 :initial-content '(#("First" 12321 nil)
614 (:foo "Yeah" :baz t))))
615 (tree (make-instance 'tree-view :model store)))
560af5c5 616
21f6214a 617 (loop
618 with iter = (make-instance 'tree-iter)
619 for i from 1 to 1000
620 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
d975a970 621
622 (let ((column (make-instance 'tree-view-column :title "Column 1"))
623 (cell (make-instance 'cell-renderer-text)))
624 (cell-layout-pack column cell :expand t)
625 (cell-layout-add-attribute column cell 'text (column-index store :foo))
626 (tree-view-append-column tree column))
627
628 (let ((column (make-instance 'tree-view-column :title "Column 2"))
629 (cell (make-instance 'cell-renderer-text :background "orange")))
630 (cell-layout-pack column cell :expand t)
631 (cell-layout-add-attribute column cell 'text (column-index store :bar))
632 (tree-view-append-column tree column))
633
634 (let ((column (make-instance 'tree-view-column :title "Column 3"))
635 (cell (make-instance 'cell-renderer-text)))
636 (cell-layout-pack column cell :expand t)
637 (cell-layout-add-attribute column cell 'text (column-index store :baz))
638 (tree-view-append-column tree column))
639
640 (make-instance 'v-box
f6ebddea 641 :parent dialog :border-width 10 :spacing 10
d975a970 642 :child (list
643 (make-instance 'h-box
644 :spacing 10
645 :child (make-instance 'button
646 :label "Remove Selection"
647 :signal (list 'clicked
648 #'(lambda ()
649 (let ((references
650 (mapcar
651 #'(lambda (path)
652 (make-instance 'tree-row-reference :model store :path path))
653 (tree-selection-get-selected-rows
654 (tree-view-selection tree)))))
655 (mapc
656 #'(lambda (reference)
657 (list-store-remove store reference))
658 references))))))
659 :expand nil)
660 :child (list
661 (make-instance 'h-box
662 :spacing 10
663 :child (make-instance 'check-button
664 :label "Show Headers" :active t
665 :signal (list 'toggled
666 #'(lambda (button)
667 (setf
668 (tree-view-headers-visible-p tree)
669 (toggle-button-active-p button)))
670 :object t))
671 :child (make-instance 'check-button
672 :label "Reorderable" :active nil
673 :signal (list 'toggled
674 #'(lambda (button)
675 (setf
676 (tree-view-reorderable-p tree)
677 (toggle-button-active-p button)))
678 :object t))
679 :child (list
680 (make-instance 'h-box
681 :child (make-instance 'label :label "Selection Mode: ")
682 :child (make-instance 'combo-box
683 :content '("Single" "Browse" "Multiple")
684 :active 0
685 :signal (list 'changed
686 #'(lambda (combo-box)
687 (setf
688 (tree-selection-mode
689 (tree-view-selection tree))
690 (svref
691 #(:single :browse :multiple)
692 (combo-box-active combo-box))))
693 :object t)))
694 :expand nil))
695 :expand nil)
696 :child (make-instance 'scrolled-window
697 :child tree :hscrollbar-policy :automatic))))
560af5c5 698
699
700;; Menus
701
702(defun create-menu (depth tearoff)
703 (unless (zerop depth)
704a1de4 704 (let ((menu (make-instance 'menu)))
560af5c5 705 (when tearoff
704a1de4 706 (let ((menu-item (make-instance 'tearoff-menu-item)))
707 (menu-shell-append menu menu-item)))
560af5c5 708 (let ((group nil))
709 (dotimes (i 5)
704a1de4 710 (let ((menu-item
711 (make-instance 'radio-menu-item
712 :label (format nil "item ~2D - ~D" depth (1+ i)))))
713 (if group
842e5ffe 714 (add-to-radio-group menu-item group)
704a1de4 715 (setq group menu-item))
560af5c5 716 (unless (zerop (mod depth 2))
704a1de4 717 (setf (check-menu-item-active-p menu-item) t))
718 (menu-shell-append menu menu-item)
560af5c5 719 (when (= i 3)
704a1de4 720 (setf (widget-sensitive-p menu-item) nil))
977a550d 721 (let ((submenu (create-menu (1- depth) t)))
722 (when submenu
723 (setf (menu-item-submenu menu-item) submenu))))))
196fe1e9 724 menu)))
560af5c5 725
726
704a1de4 727(define-simple-dialog create-menus (dialog "Menus" :default-width 200)
728 (let* ((main (make-instance 'v-box :parent dialog))
729; (accel-group (make-instance 'accel-group))
730 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
842e5ffe 731; (window-add-accel-group dialog accel-group)
704a1de4 732
733 (let ((menu-item (make-instance 'menu-item
734 :label (format nil "test~%line2"))))
735 (setf (menu-item-submenu menu-item) (create-menu 2 t))
736 (menu-shell-append menubar menu-item))
737
738 (let ((menu-item (make-instance 'menu-item :label "foo")))
739 (setf (menu-item-submenu menu-item) (create-menu 3 t))
740 (menu-shell-append menubar menu-item))
741
742 (let ((menu-item (make-instance 'menu-item :label "bar")))
743 (setf (menu-item-submenu menu-item) (create-menu 4 t))
744 (setf (menu-item-right-justified-p menu-item) t)
745 (menu-shell-append menubar menu-item))
746
613fb570 747 (make-instance 'v-box
748 :spacing 10 :border-width 10 :parent main
749 :child (make-instance 'combo-box
750 :active 3
751 :content (loop
752 for i from 1 to 5
753 collect (format nil "Item ~D" i))))
560af5c5 754
613fb570 755 (widget-show-all main)))
560af5c5 756
757
758;;; Notebook
759
977a550d 760(defun create-notebook-page (notebook page-num book-closed)
704a1de4 761 (let* ((title (format nil "Page ~D" page-num))
762 (page (make-instance 'frame :label title :border-width 10))
763 (v-box (make-instance 'v-box
764 :homogeneous t :border-width 10 :parent page)))
765
766 (make-instance 'h-box
767 :parent (list v-box :fill nil :padding 5) :homogeneous t
768 :child-args '(:padding 5)
769 :child (make-instance 'check-button
770 :label "Fill Tab" :active t
771 :signal (list 'toggled
772 #'(lambda (button)
773 (setf
774 (notebook-child-tab-fill-p page)
775 (toggle-button-active-p button)))
776 :object t))
777 :child (make-instance 'check-button
778 :label "Expand Tab"
779 :signal (list 'toggled
780 #'(lambda (button)
781 (setf
782 (notebook-child-tab-expand-p page)
783 (toggle-button-active-p button)))
784 :object t))
785 :child (make-instance 'check-button
786 :label "Pack end"
787 :signal (list 'toggled
788 #'(lambda (button)
789 (setf
790 (notebook-child-tab-pack page)
791 (if (toggle-button-active-p button)
792 :end
793 :start)))
794 :object t))
795 :child (make-instance 'button
796 :label "Hide page"
797 :signal (list 'clicked #'(lambda () (widget-hide page)))))
798
799 (let ((label-box (make-instance 'h-box
f6ebddea 800 :show-children t
704a1de4 801 :child-args '(:expand nil)
977a550d 802 :child (make-instance 'image :pixbuf book-closed)
704a1de4 803 :child (make-instance 'label :label title)))
804 (menu-box (make-instance 'h-box
f6ebddea 805 :show-children t
704a1de4 806 :child-args '(:expand nil)
977a550d 807 :child (make-instance 'image :pixbuf book-closed)
704a1de4 808 :child (make-instance 'label :label title))))
809
810 (widget-show-all page)
811 (notebook-append notebook page label-box menu-box))))
560af5c5 812
560af5c5 813
704a1de4 814(define-simple-dialog create-notebook (dialog "Notebook")
815 (let ((main (make-instance 'v-box :parent dialog)))
977a550d 816 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
817 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
818 (notebook (make-instance 'notebook
704a1de4 819 :border-width 10 :tab-pos :top :parent main)))
977a550d 820 (flet ((set-image (page func pixbuf)
821 (setf
822 (image-pixbuf
823 (first (container-children (funcall func notebook page))))
824 pixbuf)))
704a1de4 825 (signal-connect notebook 'switch-page
826 #'(lambda (pointer page)
827 (declare (ignore pointer))
842e5ffe 828 (set-image page #'notebook-menu-label book-open)
829 (set-image page #'notebook-tab-label book-open)
830 (when (slot-boundp notebook 'current-page)
704a1de4 831 (let ((curpage (notebook-current-page notebook)))
842e5ffe 832 (set-image curpage #'notebook-menu-label book-closed)
833 (set-image curpage #'notebook-tab-label book-closed))))))
977a550d 834 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
704a1de4 835
836 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
837
838 (make-instance 'h-box
839 :spacing 5 :border-width 10
840 :parent (list main :expand nil)
841 :child-args '(:fill nil)
842 :child (make-instance 'check-button
843 :label "Popup menu"
844 :signal (list 'clicked
845 #'(lambda (button)
846 (if (toggle-button-active-p button)
847 (notebook-popup-enable notebook)
848 (notebook-popup-disable notebook)))
849 :object t))
850 :child (make-instance 'check-button
851 :label "Homogeneous tabs"
852 :signal (list 'clicked
853 #'(lambda (button)
854 (setf
855 (notebook-homogeneous-p notebook)
856 (toggle-button-active-p button)))
857 :object t)))
858
859 (make-instance 'h-box
860 :spacing 5 :border-width 10
861 :parent (list main :expand nil)
862 :child-args '(:expand nil)
863 :child (make-instance 'label :label "Notebook Style: ")
864 :child (let ((scrollable-p nil))
613fb570 865 (make-instance 'combo-box
866 :content '("Standard" "No tabs" "Scrollable") :active 0
867 :signal (list 'changed
868 #'(lambda (combo-box)
869 (case (combo-box-active combo-box)
870 (0
871 (setf (notebook-show-tabs-p notebook) t)
872 (when scrollable-p
873 (setq scrollable-p nil)
874 (setf (notebook-scrollable-p notebook) nil)
875 (loop repeat 10
876 do (notebook-remove-page notebook 5))))
877 (1
878 (setf (notebook-show-tabs-p notebook) nil)
879 (when scrollable-p
880 (setq scrollable-p nil)
881 (setf (notebook-scrollable-p notebook) nil)
882 (loop repeat 10
883 do (notebook-remove-page notebook 5))))
884 (2
885 (unless scrollable-p
886 (setq scrollable-p t)
887 (setf (notebook-show-tabs-p notebook) t)
888 (setf (notebook-scrollable-p notebook) t)
889 (loop for i from 6 to 15
977a550d 890 do (create-notebook-page notebook i book-closed))))))
613fb570 891 :object t)))
704a1de4 892 :child (make-instance 'button
893 :label "Show all Pages"
894 :signal (list 'clicked
895 #'(lambda ()
896 (map-container nil #'widget-show notebook)))))
897
898 (make-instance 'h-box
899 :spacing 5 :border-width 10
900 :parent (list main :expand nil)
901 :child (make-instance 'button
902 :label "prev"
903 :signal (list 'clicked #'notebook-prev-page :object notebook))
904 :child (make-instance 'button
905 :label "next"
906 :signal (list 'clicked #'notebook-next-page :object notebook))
907 :child (make-instance 'button
908 :label "rotate"
909 :signal (let ((tab-pos 0))
910 (list 'clicked
911 #'(lambda ()
912 (setq tab-pos (mod (1+ tab-pos) 4))
913 (setf
914 (notebook-tab-pos notebook)
915 (svref #(:top :right :bottom :left) tab-pos))))))))
916 (widget-show-all main)))
560af5c5 917
918
919;;; Panes
920
921(defun toggle-resize (child)
812dd869 922 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
560af5c5 923
924(defun toggle-shrink (child)
812dd869 925 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
560af5c5 926
927(defun create-pane-options (paned frame-label label1 label2)
812dd869 928 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
33f468b7 929 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
704a1de4 930 (let ((check-button (make-instance 'check-button :label "Resize")))
33f468b7 931 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
812dd869 932 (signal-connect check-button 'toggled
933 #'toggle-resize :object (paned-child1 paned)))
934 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
33f468b7 935 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
812dd869 936 (signal-connect check-button 'toggled
937 #'toggle-shrink :object (paned-child1 paned)))
560af5c5 938
33f468b7 939 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
812dd869 940 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
33f468b7 941 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
812dd869 942 (signal-connect check-button 'toggled
943 #'toggle-resize :object (paned-child2 paned)))
944 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
33f468b7 945 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
812dd869 946 (signal-connect check-button 'toggled
947 #'toggle-shrink :object (paned-child2 paned)))
948 (make-instance 'frame :label frame-label :border-width 4 :child table)))
560af5c5 949
704a1de4 950(define-toplevel create-panes (window "Panes")
951 (let* ((hpaned (make-instance 'h-paned
196fe1e9 952 :child1 (make-instance 'frame
704a1de4 953 :width-request 60 :height-request 60
954 :shadow-type :in
812dd869 955 :child (make-instance 'button :label "Hi there"))
704a1de4 956 :child2 (make-instance 'frame
957 :width-request 80 :height-request 60
958 :shadow-type :in)))
959 (vpaned (make-instance 'v-paned
196fe1e9 960 :border-width 5
961 :child1 hpaned
962 :child2 (make-instance 'frame
704a1de4 963 :width-request 80 :height-request 60
964 :shadow-type :in))))
196fe1e9 965
704a1de4 966 (make-instance 'v-box
196fe1e9 967 :parent window
704a1de4 968 :child-args '(:expand nil)
969 :child (list vpaned :expand t)
970 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
971 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
560af5c5 972
973
560af5c5 974;;; Progress bar
975
977a550d 976(define-simple-dialog create-progress-bar (dialog "Progress Bar")
977 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
978 (activity-mode-button (make-instance 'check-button
979 :label "Activity mode"))
980 (timer (timeout-add 100
981 #'(lambda ()
982 (if (toggle-button-active-p activity-mode-button)
983 (progress-bar-pulse progress)
984 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
985 (setf
986 (progress-bar-fraction progress)
987 (if (> fract 1.0)
988 0.0
989 fract))))
990 t))))
991
992 (make-instance 'v-box
f6ebddea 993 :parent dialog :border-width 10 :spacing 10
977a550d 994 :child progress
995 :child activity-mode-button)
996
997 (signal-connect dialog 'destroy
998 #'(lambda () (when timer (timeout-remove timer))))))
560af5c5 999
1000
1001;;; Radio buttons
1002
704a1de4 1003(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1004 (make-instance 'v-box
f6ebddea 1005 :parent dialog :border-width 10 :spacing 10
787721b6 1006 :children (make-radio-group 'radio-button
1007 '((:label "button1") (:label "button2") (:label "button3"))
1008 nil)))
560af5c5 1009
1010
1011;;; Rangle controls
1012
704a1de4 1013(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1014 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 1015 (make-instance 'v-box
f6ebddea 1016 :parent dialog :border-width 10 :spacing 10
704a1de4 1017 :child (make-instance 'h-scale
1018 :width-request 150 :adjustment adjustment :inverted t
1019 :update-policy :delayed :digits 1 :draw-value t)
1020 :child (make-instance 'h-scrollbar
1021 :adjustment adjustment :update-policy :continuous))))
560af5c5 1022
1023
1024;;; Reparent test
1025
704a1de4 1026(define-simple-dialog create-reparent (dialog "Reparent")
1027 (let ((main (make-instance 'h-box
1028 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
977a550d 1029 (label (make-instance 'label :label "Hello World")))
560af5c5 1030
704a1de4 1031 (flet ((create-frame (title)
1032 (let* ((frame (make-instance 'frame :label title :parent main))
1033 (box (make-instance 'v-box
1034 :spacing 5 :border-width 5 :parent frame))
1035 (button (make-instance 'button
1036 :label "switch" :parent (list box :expand nil))))
1037 (signal-connect button 'clicked
1038 #'(lambda ()
1039 (widget-reparent label box)))
1040 box)))
560af5c5 1041
704a1de4 1042 (box-pack-start (create-frame "Frame 1") label nil t 0)
1043 (create-frame "Frame 2"))
1044 (widget-show-all main)))
560af5c5 1045
1046
1047;;; Rulers
1048
704a1de4 1049(define-toplevel create-rulers (window "Rulers"
1050 :default-width 300 :default-height 300
4280ef98 1051 :events '(:pointer-motion :pointer-motion-hint))
33f468b7 1052 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1053 (h-ruler (make-instance 'h-ruler
704a1de4 1054 :metric :centimeters :lower 100.0d0 :upper 0.0d0
33f468b7 1055 :position 0.0d0 :max-size 20.0d0))
1056 (v-ruler (make-instance 'v-ruler
704a1de4 1057 :lower 5.0d0 :upper 15.0d0
1058 :position 0.0d0 :max-size 20.0d0)))
33f468b7 1059 (signal-connect window 'motion-notify-event
1060 #'(lambda (event)
1061 (widget-event h-ruler event)
1062 (widget-event v-ruler event)))
1063 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1064 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
560af5c5 1065
1066
1067;;; Scrolled window
1068
704a1de4 1069(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1070 :default-width 300
1071 :default-height 300)
196fe1e9 1072 (let* ((scrolled-window
1073 (make-instance 'scrolled-window
704a1de4 1074 :parent dialog :border-width 10
1075 :vscrollbar-policy :automatic
196fe1e9 1076 :hscrollbar-policy :automatic))
1077 (table
1078 (make-instance 'table
704a1de4 1079 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1080 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1081 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1082
560af5c5 1083 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1084 (dotimes (i 20)
1085 (dotimes (j 20)
1086 (let ((button
704a1de4 1087 (make-instance 'toggle-button
1088 :label (format nil "button (~D,~D)~%" i j))))
1089 (table-attach table button i (1+ i) j (1+ j)))))
1090 (widget-show-all scrolled-window)))
560af5c5 1091
1092
33f468b7 1093;;; Size group
1094
1095(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1096 (let ((size-group (make-instance 'size-group)))
1097 (flet ((create-frame (label rows)
1098 (let ((table (make-instance 'table
1099 :n-rows (length rows) :n-columns 2 :homogeneous nil
1100 :row-spacing 5 :column-spacing 10 :border-width 5)))
1101 (loop
1102 for row in rows
1103 for i from 0
1104 do (table-attach table
1105 (create-label (first row) :xalign 0 :yalign 1)
1106 0 1 i (1+ i) :x-options '(:expand :fill))
1107 (let ((combo (make-instance 'combo-box
1108 :content (rest row) :active 0)))
1109 (size-group-add-widget size-group combo)
1110 (table-attach table combo 1 2 i (1+ i))))
1111 (make-instance 'frame :label label :child table))))
1112
1113 (make-instance 'v-box
f6ebddea 1114 :parent dialog :border-width 5 :spacing 5
33f468b7 1115 :child (create-frame "Color Options"
1116 '(("Foreground" "Red" "Green" "Blue")
1117 ("Background" "Red" "Green" "Blue")))
1118 :child (create-frame "Line Options"
1119 '(("Dashing" "Solid" "Dashed" "Dotted")
1120 ("Line ends" "Square" "Round" "Arrow")))
1121 :child (create-check-button "Enable grouping"
1122 #'(lambda (active)
1123 (setf
1124 (size-group-mode size-group)
1125 (if active :horizontal :none)))
1126 t)))))
1127
1128
560af5c5 1129;;; Shapes
1130
9257d518 1131(defun create-shape-icon (xpm-file x y px py type root-window destroy)
1132 (let ((window
1133 (make-instance 'window
1134 :type type :default-width 100 :default-height 100
1135 :events '(:button-motion :pointer-motion-hint :button-press)
1136 :signal (list 'destroy destroy))))
196fe1e9 1137
9257d518 1138 (widget-realize window)
1139 (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1140 (let ((fixed (make-instance 'fixed :parent window)))
1141 (fixed-put fixed (create-image-widget source mask) px py))
1142 (widget-shape-combine-mask window mask px py))
196fe1e9 1143
9257d518 1144 (let ((x-offset 0)
1145 (y-offset 0))
1146 (declare (fixnum x-offset y-offset))
1147 (signal-connect window 'button-press-event
1148 #'(lambda (event)
1149 (when (typep event 'gdk:button-press-event)
1150 (setq x-offset (truncate (gdk:event-x event)))
1151 (setq y-offset (truncate (gdk:event-y event)))
1152 (grab-add window)
1153 (gdk:pointer-grab (widget-window window)
1154 :events '(:button-release :button-motion :pointer-motion-hint)
1155 :owner-events t :time event))))
1156
1157 (signal-connect window 'button-release-event
1158 #'(lambda (event)
1159 (grab-remove window)
1160 (gdk:pointer-ungrab event)))
560af5c5 1161
9257d518 1162 (signal-connect window 'motion-notify-event
1163 #'(lambda (event)
1164 (declare (ignore event))
1165 (multiple-value-bind (win xp yp mask)
1166 (gdk:window-get-pointer root-window)
1167 (declare (ignore mask win) (fixnum xp yp))
1168 (window-move window (- xp x-offset) (- yp y-offset))))))
560af5c5 1169
9257d518 1170 (window-move window x y)
1171 (widget-show-all window)
1172 window))
1173
1174
1175(let ((modeller nil)
1176 (sheets nil)
1177 (rings nil))
1178 (defun create-shapes ()
1179 (let ((root-window (gdk:get-root-window)))
1180 (if (not modeller)
1181 (setq
1182 modeller
1183 (create-shape-icon
1184 "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1185 #'(lambda () (setq modeller nil))))
1186 (widget-destroy modeller))
1187
1188 (if (not sheets)
1189 (setq
1190 sheets
1191 (create-shape-icon
1192 "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1193 #'(lambda () (setq sheets nil))))
1194 (widget-destroy sheets))
1195
1196 (if (not rings)
1197 (setq
1198 rings
1199 (create-shape-icon
1200 "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1201 #'(lambda () (setq rings nil))))
1202 (widget-destroy rings)))))
560af5c5 1203
1204
1205
1206;;; Spin buttons
1207
704a1de4 1208(define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1209 (let ((main (make-instance 'v-box
1210 :spacing 5 :border-width 10 :parent dialog)))
1211
1212 (flet ((create-date-spinner (label adjustment shadow-type)
1213 (declare (ignore shadow-type))
1214 (make-instance 'v-box
1215 :child-args '(:expand nil)
1216 :child (make-instance 'label
1217 :label label :xalign 0.0 :yalign 0.5)
1218 :child (make-instance 'spin-button
1219 :adjustment adjustment :wrap t))))
1220 (make-instance 'frame
1221 :label "Not accelerated" :parent main
1222 :child (make-instance 'h-box
1223 :border-width 10
1224 :child-args '(:padding 5)
1225 :child (create-date-spinner "Day : "
1226 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1227 :child (create-date-spinner "Month : "
c775862e 1228 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
704a1de4 1229 :child (create-date-spinner "Year : "
1230 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1231
1232 (let ((spinner1 (make-instance 'spin-button
1233 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1234 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1235 (spinner2 (make-instance 'spin-button
1236 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1237 :climb-rate 1.0 :wrap t))
1238 (value-label (make-instance 'label :label "0")))
1239 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1240 #'(lambda ()
1241 (setf
1242 (spin-button-digits spinner1)
1243 (floor (spin-button-value spinner2)))))
1244
1245 (make-instance 'frame
1246 :label "Accelerated" :parent main
1247 :child (make-instance 'v-box
1248 :border-width 5
1249 :child (list
1250 (make-instance 'h-box
1251 :child-args '(:padding 5)
1252 :child (make-instance 'v-box
1253 :child (make-instance 'label
1254 :label "Value :"
1255 :xalign 0.0 :yalign 0.5)
1256 :child spinner1)
1257 :child (make-instance 'v-box
1258 :child (make-instance 'label
1259 :label "Digits :"
1260 :xalign 0.0 :yalign 0.5)
1261 :child spinner2))
1262 :expand nil :padding 5)
1263 :child (make-instance 'check-button
1264 :label "Snap to 0.5-ticks" :active t
1265 :signal (list 'clicked
1266 #'(lambda (button)
1267 (setf
1268 (spin-button-snap-to-ticks-p spinner1)
1269 (toggle-button-active-p button)))
1270 :object t))
1271 :child (make-instance 'check-button
1272 :label "Numeric only input mode" :active t
1273 :signal (list 'clicked
1274 #'(lambda (button)
1275 (setf
1276 (spin-button-numeric-p spinner1)
1277 (toggle-button-active-p button)))
1278 :object t))
1279 :child value-label
1280 :child (list
1281 (make-instance 'h-box
1282 :child-args '(:padding 5)
1283 :child (make-instance 'button
1284 :label "Value as Int"
1285 :signal (list 'clicked
1286 #'(lambda ()
1287 (setf
1288 (label-label value-label)
1289 (format nil "~D"
1290 (spin-button-value-as-int
1291 spinner1))))))
1292 :child (make-instance 'button
1293 :label "Value as Float"
1294 :signal (list 'clicked
1295 #'(lambda ()
1296 (setf
1297 (label-label value-label)
1298 (format nil
1299 (format nil "~~,~DF"
1300 (spin-button-digits spinner1))
1301 (spin-button-value spinner1)))))))
1302 :padding 5 :expand nil))))
1303 (widget-show-all main)))
560af5c5 1304
704a1de4 1305
c775862e 1306;;; Statusbar
560af5c5 1307
c775862e 1308(define-toplevel create-statusbar (window "Statusbar")
1309 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1310 (close-button (create-button '("close" :can-default t)
1311 #'widget-destroy :object window))
1312 (counter 0))
1313
1314 (signal-connect statusbar 'text-popped
1315 #'(lambda (context-id text)
1316 (declare (ignore context-id))
1317 (format nil "Popped: ~A~%" text)))
1318
1319 (make-instance 'v-box
1320 :parent window
1321 :child (make-instance 'v-box
1322 :border-width 10 :spacing 10
1323 :child (create-button "push something"
1324 #'(lambda ()
1325 (statusbar-push statusbar 1
1326 (format nil "something ~D" (incf counter)))))
1327 :child (create-button "pop"
1328 #'(lambda ()
1329 (statusbar-pop statusbar 1)))
1330 :child (create-button "steal #4"
1331 #'(lambda ()
1332 (statusbar-remove statusbar 1 4)))
1333 :child (create-button "dump stack")
1334 :child (create-button "test contexts"))
1335 :child (list (make-instance 'h-separator) :expand nil)
1336 :child (list
1337 (make-instance 'v-box :border-width 10 :child close-button)
1338 :expand nil)
1339 :child (list statusbar :expand nil))
1340
1341 (widget-grab-focus close-button)))
560af5c5 1342
1343
1344;;; Idle test
1345
bdc1babf 1346(define-simple-dialog create-idle-test (dialog "Idle Test")
1347 (let ((label (make-instance 'label
1348 :label "count: 0" :xpad 10 :ypad 10))
1349 (idle nil)
1350 (count 0))
1351 (signal-connect dialog 'destroy
1352 #'(lambda () (when idle (idle-remove idle))))
560af5c5 1353
bdc1babf 1354 (make-instance 'v-box
f6ebddea 1355 :parent dialog :border-width 10 :spacing 10
bdc1babf 1356 :child label
1357 :child (make-instance 'frame
1358 :label "Label Container" :border-width 5
1359 :child(make-instance 'v-box
787721b6 1360 :children (make-radio-group 'radio-button
1361 '((:label "Resize-Parent" :value :parent :active t)
1362 (:label "Resize-Queue" :value :queue)
1363 (:label "Resize-Immediate" :value :immediate))
bdc1babf 1364 #'(lambda (mode)
1365 (setf
1366 (container-resize-mode (dialog-action-area dialog)) mode))))))
1367
1368 (dialog-add-button dialog "Start"
1369 #'(lambda ()
1370 (unless idle
1371 (setq idle
1372 (idle-add
1373 #'(lambda ()
1374 (incf count)
1375 (setf (label-label label) (format nil "count: ~D" count))
1376 t))))))
560af5c5 1377
bdc1babf 1378 (dialog-add-button dialog "Stop"
1379 #'(lambda ()
1380 (when idle
1381 (idle-remove idle)
1382 (setq idle nil))))))
560af5c5 1383
1384
1385
1386;;; Timeout test
1387
bdc1babf 1388(define-simple-dialog create-timeout-test (dialog "Timeout Test")
1389 (let ((label (make-instance 'label
1390 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1391 (timer nil)
1392 (count 0))
1393 (signal-connect dialog 'destroy
1394 #'(lambda () (when timer (timeout-remove timer))))
1395
1396 (dialog-add-button dialog "Start"
1397 #'(lambda ()
1398 (unless timer
1399 (setq timer
1400 (timeout-add 100
1401 #'(lambda ()
1402 (incf count)
1403 (setf (label-label label) (format nil "count: ~D" count))
1404 t))))))
1405
1406 (dialog-add-button dialog "Stop"
1407 #'(lambda ()
1408 (when timer
1409 (timeout-remove timer)
1410 (setq timer nil))))))
dddfc333 1411
1412
1413;;; Text
1414
1415(define-simple-dialog create-text (dialog "Text" :default-width 400
1416 :default-height 400)
33f468b7 1417 (let* ((text-view (make-instance 'text-view
1418 :border-width 10 :visible t :wrap-mode :word))
1419 (buffer (text-view-buffer text-view))
1420 (active-tags ()))
1421
1422 (text-buffer-create-tag buffer "Bold" :weight :bold)
1423 (text-buffer-create-tag buffer "Italic" :style :italic)
1424 (text-buffer-create-tag buffer "Underline" :underline :single)
1425
1426 (flet ((create-toggle-callback (tag-name)
1427 (let ((tag (text-tag-table-lookup
1428 (text-buffer-tag-table buffer) tag-name)))
1429 #'(lambda (active)
1430 (unless (eq (and (find tag active-tags) t) active)
1431 ;; user activated
1432 (if active
1433 (push tag active-tags)
1434 (setq active-tags (delete tag active-tags)))
842e5ffe 1435 (multiple-value-bind (non-zero-p start end)
1436 (text-buffer-get-selection-bounds buffer)
f6ebddea 1437 (declare (ignore non-zero-p))
33f468b7 1438 (if active
1439 (text-buffer-apply-tag buffer tag start end)
1440 (text-buffer-remove-tag buffer tag start end))))))))
1441
1442 (let* ((actions
1443 (make-instance 'action-group
1444 :action (create-toggle-action
1445 "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1446 (create-toggle-callback "Bold"))
1447 :action (create-toggle-action
1448 "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1449 (create-toggle-callback "Italic"))
1450 :action (create-toggle-action
1451 "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1452 (create-toggle-callback "Underline"))))
1453 (ui (make-instance 'ui-manager)))
1454
1455 (ui-manager-insert-action-group ui actions)
1456 (ui-manager-add-ui ui
1457 '((:toolbar "ToolBar"
1458 (:toolitem "Bold")
1459 (:toolitem "Italic")
1460 (:toolitem "Underline"))))
1461
1462 ;; Callback to activate/deactivate toolbar buttons when cursor
1463 ;; is moved
1464 (signal-connect buffer 'mark-set
1465 #'(lambda (location mark)
1466 (declare (ignore mark))
1467 (text-tag-table-foreach (text-buffer-tag-table buffer)
1468 #'(lambda (tag)
1469 (let ((active
1470 (or
1471 (and
1472 (text-iter-has-tag-p location tag)
1473 (not (text-iter-begins-tag-p location tag)))
1474 (text-iter-ends-tag-p location tag))))
1475 (unless (eq active (and (find tag active-tags) t))
1476 (if active
1477 (push tag active-tags)
1478 (setq active-tags (delete tag active-tags)))
1479 (setf
1480 (toggle-action-active-p
1481 (action-group-get-action actions (text-tag-name tag)))
1482 active)))))))
1483
1484 ;; Callback to apply active tags when a character is inserted
1485 (signal-connect buffer 'insert-text
1486 #'(lambda (iter &rest args)
1487 (declare (ignore args))
1488 (let ((before (text-buffer-get-iter-at-offset buffer
1489 (1- (text-iter-offset iter)))))
1490 (loop
1491 for tag in active-tags
1492 do (text-buffer-apply-tag buffer tag before iter))))
1493 :after t)
1494
1495 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1496 (container-add dialog text-view)))))
1497
560af5c5 1498
560af5c5 1499;;; Toggle buttons
1500
704a1de4 1501(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1502 (make-instance 'v-box
f6ebddea 1503 :border-width 10 :spacing 10 :parent dialog
704a1de4 1504 :children (loop
1505 for n from 1 to 3
1506 collect (make-instance 'toggle-button
1507 :label (format nil "Button~D" (1+ n))))))
560af5c5 1508
1509
1510
1511;;; Toolbar test
1512
842e5ffe 1513(defun create-toolbar (window)
787721b6 1514 (make-instance 'toolbar
842e5ffe 1515 :show-tooltips t :show-arrow nil
787721b6 1516
1517 ;; Insert a stock item
1518 :child (make-instance 'tool-button
1519 :stock "gtk-quit"
1520 :tip-text "Destroy toolbar"
1521 :tip-private "Toolbar/Quit"
1522 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1523
1524 :child (make-instance 'separator-tool-item)
1525
1526 :child (make-instance 'tool-button
1527 :label "Horizontal" :stock "gtk-go-forward"
1528 :tip-text "Horizontal toolbar layout"
1529 :tip-private "Toolbar/Horizontal"
1530 :signal (list 'clicked
1531 #'(lambda (toolbar)
1532 (setf (toolbar-orientation toolbar) :horizontal))
1533 :object :parent))
1534
1535 :child (make-instance 'tool-button
1536 :label "Vertical" :stock "gtk-go-down"
1537 :tip-text "Vertical toolbar layout"
1538 :tip-private "Toolbar/Vertical"
1539 :signal (list 'clicked
1540 #'(lambda (toolbar)
1541 (setf (toolbar-orientation toolbar) :vertical))
1542 :object :parent))
1543
1544 :child (make-instance 'separator-tool-item)
1545
1546 :children (make-radio-group 'radio-tool-button
1547 '((:label "Icons" :stock "gtk-justify-left"
1548 :tip-text "Only show toolbar icons"
1549 :tip-private "Toolbar/IconsOnly"
1550 :value :icons)
1551 (:label "Both" :stock "gtk-justify-center"
1552 :tip-text "Show toolbar icons and text"
1553 :tip-private "Toolbar/Both"
1554 :value :both :active t)
1555 (:label "Text" :stock "gtk-justify-right"
1556 :tip-text "Show toolbar text"
1557 :tip-private "Toolbar/TextOnly"
1558 :value :text))
1559 (list
1560 #'(lambda (toolbar style)
1561 (setf (toolbar-style toolbar) style))
1562 :object :parent))
1563
1564 :child (make-instance 'separator-tool-item)
1565
1566 :child (make-instance 'tool-item
1567 :child (make-instance 'entry)
1568 :tip-text "This is an unusable GtkEntry"
1569 :tip-private "Hey don't click me!")
1570
1571 :child (make-instance 'separator-tool-item)
1572
1573 :child (make-instance 'tool-button
1574 :label "Enable" :stock "gtk-add"
1575 :tip-text "Enable tooltips"
1576 :tip-private "Toolbar/EnableTooltips"
1577 :signal (list 'clicked
1578 #'(lambda (toolbar)
1579 (setf (toolbar-show-tooltips-p toolbar) t))
1580 :object :parent))
1581
1582 :child (make-instance 'tool-button
1583 :label "Disable" :stock "gtk-remove"
1584 :tip-text "Disable tooltips"
1585 :tip-private "Toolbar/DisableTooltips"
1586 :signal (list 'clicked
1587 #'(lambda (toolbar)
1588 (setf (toolbar-show-tooltips-p toolbar) nil))
1589 :object :parent))
1590
1591;; :child (make-instance 'separator-tool-item)
1592
1593;; :child (make-instance 'tool-button
1594;; :label "GTK" :icon #p"clg:examples;gtk.png"
1595;; :tip-text "GTK+ Logo"
1596;; :tip-private "Toolbar/GTK+")
1597 ))
560af5c5 1598
842e5ffe 1599(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1600 (container-add window (create-toolbar window)))
1601
560af5c5 1602
1603
1604;;; Tooltips test
1605
bdc1babf 1606(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1607 (let ((tooltips (make-instance 'tooltips)))
1608 (flet ((create-button (label tip-text tip-private)
1609 (let ((button (make-instance 'toggle-button :label label)))
1610 (tooltips-set-tip tooltips button tip-text tip-private)
1611 button)))
1612 (make-instance 'v-box
f6ebddea 1613 :parent dialog :border-width 10 :spacing 10
bdc1babf 1614 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
812dd869 1615 :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
dddfc333 1616
1617
1618;;; UI Manager
1619
1620(defvar *ui-description*
1621 '((:menubar "MenuBar"
1622 (:menu "FileMenu"
1623 (:menuitem "New")
1624 (:menuitem "Open")
1625 (:menuitem "Save")
1626 (:menuitem "SaveAs")
1627 :separator
1628 (:menuitem "Quit"))
1629 (:menu "PreferencesMenu"
1630 (:menu "ColorMenu"
1631 (:menuitem "Red")
1632 (:menuitem "Green")
1633 (:menuitem "Blue"))
1634 (:menu "ShapeMenu"
1635 (:menuitem "Square")
1636 (:menuitem "Rectangle")
1637 (:menuitem "Oval"))
1638 (:menuitem "Bold"))
1639 (:menu "HelpMenu"
1640 (:menuitem "About")))
1641 (:toolbar "ToolBar"
1642 (:toolitem "Open")
1643 (:toolitem "Quit")
1644 (:separator "Sep1")
1645 (:toolitem "Logo"))))
1646
33f468b7 1647(define-toplevel create-ui-manager (window "UI Manager")
dddfc333 1648 (let ((actions
1649 (make-instance 'action-group
1650 :name "Actions"
1651 :action (create-action "FileMenu" nil "_File")
1652 :action (create-action "PreferencesMenu" nil "_Preferences")
1653 :action (create-action "ColorMenu" nil "_Color")
1654 :action (create-action "ShapeMenu" nil "_Shape")
1655 :action (create-action "HelpMenu" nil "_Help")
1656 :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
33f468b7 1657 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
dddfc333 1658 :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1659 :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
33f468b7 1660 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
dddfc333 1661 :action (create-action "About" nil "_About" "<control>A" "About")
1662 :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1663 :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1664 :actions (create-radio-actions
1665 '(("Red" nil "_Red" "<control>R" "Blood")
1666 ("Green" nil "_Green" "<control>G" "Grass")
1667 ("Blue" nil "_Blue" "<control>B" "Sky"))
1668 "Green")
1669 :actions (create-radio-actions
1670 '(("Square" nil "_Square" "<control>S" "Square")
1671 ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1672 ("Oval" nil "_Oval" "<control>O" "Egg")))))
1673 (ui (make-instance 'ui-manager)))
1674
1675 (ui-manager-insert-action-group ui actions)
1676 (ui-manager-add-ui ui *ui-description*)
1677
33f468b7 1678 (window-add-accel-group window (ui-manager-accel-group ui))
dddfc333 1679
1680 (make-instance 'v-box
f6ebddea 1681 :parent window
dddfc333 1682 :child (list
1683 (ui-manager-get-widget ui "/MenuBar")
1684 :expand nil :fill nil)
1685 :child (list
1686 (ui-manager-get-widget ui "/ToolBar")
1687 :expand nil :fill nil)
1688 :child (make-instance 'label
1689 :label "Type <alt> to start"
1690 :xalign 0.5 :yalign 0.5
1691 :width-request 200 :height-request 200))))
560af5c5 1692
1693
1694
560af5c5 1695;;; Main window
1696
1697(defun create-main-window ()
704a1de4 1698;; (rc-parse "clg:examples;testgtkrc2")
1699;; (rc-parse "clg:examples;testgtkrc")
196fe1e9 1700
1701 (let* ((button-specs
560af5c5 1702 '(("button box" create-button-box)
704a1de4 1703 ("buttons" create-buttons)
1704 ("calendar" create-calendar)
1705 ("check buttons" create-check-buttons)
704a1de4 1706 ("color selection" create-color-selection)
aa9ceddc 1707 ("cursors" create-cursors)
704a1de4 1708 ("dialog" create-dialog)
1709;; ; ("dnd")
1710 ("entry" create-entry)
1711;; ("event watcher")
96b68e83 1712 ("enxpander" create-expander)
704a1de4 1713 ("file chooser" create-file-chooser)
3f315085 1714 ("font selection" create-font-selection)
842e5ffe 1715 ("handle box" create-handle-box)
704a1de4 1716 ("image" create-image)
704a1de4 1717 ("labels" create-labels)
1718 ("layout" create-layout)
21f6214a 1719 ("list" create-list)
560af5c5 1720 ("menus" create-menus)
704a1de4 1721;; ("modal window")
1722 ("notebook" create-notebook)
1723 ("panes" create-panes)
977a550d 1724 ("progress bar" create-progress-bar)
704a1de4 1725 ("radio buttons" create-radio-buttons)
1726 ("range controls" create-range-controls)
1727;; ("rc file")
1728 ("reparent" create-reparent)
1729 ("rulers" create-rulers)
1730;; ("saved position")
1731 ("scrolled windows" create-scrolled-windows)
33f468b7 1732 ("size group" create-size-group)
9257d518 1733 ("shapes" create-shapes)
704a1de4 1734 ("spinbutton" create-spins)
c775862e 1735 ("statusbar" create-statusbar)
bdc1babf 1736 ("test idle" create-idle-test)
704a1de4 1737;; ("test mainloop")
1738;; ("test scrolling")
1739;; ("test selection")
bdc1babf 1740 ("test timeout" create-timeout-test)
dddfc333 1741 ("text" create-text)
704a1de4 1742 ("toggle buttons" create-toggle-buttons)
842e5ffe 1743 ("toolbar" create-toolbar-window)
bdc1babf 1744 ("tooltips" create-tooltips)
704a1de4 1745;; ("tree" #|create-tree|#)
dddfc333 1746 ("UI manager" create-ui-manager)
704a1de4 1747))
1748 (main-window (make-instance 'window
1749 :title "testgtk.lisp" :name "main_window"
1750 :default-width 200 :default-height 400
1751 :allow-grow t :allow-shrink nil))
1752 (scrolled-window (make-instance 'scrolled-window
1753 :hscrollbar-policy :automatic
1754 :vscrollbar-policy :automatic
1755 :border-width 10))
1756 (close-button (make-instance 'button
1757 :label "close" :can-default t
1758 :signal (list 'clicked #'widget-destroy
1759 :object main-window))))
560af5c5 1760
977a550d 1761 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1762 (setf
1763 (window-icon main-window)
1764 (gdk:pixbuf-add-alpha icon t 254 254 252)))
812dd869 1765
560af5c5 1766 ;; Main box
704a1de4 1767 (make-instance 'v-box
560af5c5 1768 :parent main-window
704a1de4 1769 :child-args '(:expand nil)
1770 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1771 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1772 :child (list scrolled-window :expand t)
1773 :child (make-instance 'h-separator)
1774 :child (make-instance 'v-box
1775 :homogeneous nil :spacing 10 :border-width 10
1776 :child close-button))
1777
1778 (let ((content-box
1779 (make-instance 'v-box
1780 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1781 :children (mapcar #'(lambda (spec)
1782 (apply #'create-button spec))
1783 button-specs))))
1784 (scrolled-window-add-with-viewport scrolled-window content-box))
560af5c5 1785
704a1de4 1786 (widget-grab-focus close-button)
560af5c5 1787 (widget-show-all main-window)
1788 main-window))
1789
704a1de4 1790(clg-init)
1791(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).