~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Added font selection
[clg] / examples / testgtk.lisp
CommitLineData
0d07716f 1;; Common Lisp bindings for GTK+ v2.0
8179fd68 2;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
0d07716f 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
b9d3ad20 18;; $Id: testgtk.lisp,v 1.21 2005/02/27 13:28:19 espen Exp $
0d07716f 19
35ec512c 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))
0d07716f 26 (defun ,name ()
35ec512c 27 (unless ,window
6490e9f1 28 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
35ec512c 29 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
0d07716f 30 ,@body)
31
35ec512c 32 (if (not (widget-visible-p ,window))
6490e9f1 33 (widget-show ,window)
35ec512c 34 (widget-hide ,window)))))
35
0d07716f 36
35ec512c 37(defmacro define-dialog (name (dialog title &optional (class 'dialog)
38 &rest initargs)
39 &body body)
40 `(let ((,dialog nil))
0d07716f 41 (defun ,name ()
35ec512c 42 (unless ,dialog
6490e9f1 43 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
35ec512c 44 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
45 ,@body)
0d07716f 46
35ec512c 47 (if (not (widget-visible-p ,dialog))
48 (widget-show ,dialog)
49 (widget-hide ,dialog)))))
0d07716f 50
51
35ec512c 52(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
53 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
e025589b 54 ,@body
55 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
0d07716f 56
57
0d07716f 58
59;;; Pixmaps used in some of the tests
60
61(defvar gtk-mini-xpm
4fb50b71 62 #("15 20 17 1"
0d07716f 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
4fb50b71 102 #("16 16 6 1"
0d07716f 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
4fb50b71 127 #("16 16 4 1"
0d07716f 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
4fb50b71 150 #("16 16 4 1"
0d07716f 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
4fb50b71 176(defun create-bbox-in-frame (class frame-label spacing width height layout)
35ec512c 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
8804934b 182 :child (make-instance 'button :stock "gtk-ok")
183 :child (make-instance 'button :stock "gtk-cancel")
184 :child (make-instance 'button :stock "gtk-help"))))
35ec512c 185
186(define-toplevel create-button-box (window "Button Boxes")
187 (make-instance 'v-box
6490e9f1 188 :parent window :border-width 10 :spacing 10
35ec512c 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)))))))
4fb50b71 213
214
215;; Buttons
216
35ec512c 217(define-simple-dialog create-buttons (dialog "Buttons")
4fb50b71 218 (let ((table (make-instance 'table
35ec512c 219 :n-rows 3 :n-columns 3 :homogeneous nil
4fb50b71 220 :row-spacing 5 :column-spacing 5 :border-width 10
35ec512c 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
4fb50b71 227 (dotimes (column 3)
228 (dotimes (row 3)
35ec512c 229 (let ((button (nth (+ (* 3 row) column) buttons))
230 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
4fb50b71 231 (signal-connect button 'clicked
232 #'(lambda ()
233 (if (widget-visible-p button+1)
234 (widget-hide button+1)
235 (widget-show button+1))))
81f2aa93 236 (table-attach table button column (1+ column) row (1+ row)
6490e9f1 237 :options '(:expand :fill)))))))
0d07716f 238
239
240;; Calenadar
241
35ec512c 242(define-simple-dialog create-calendar (dialog "Calendar")
243 (make-instance 'v-box
6490e9f1 244 :parent dialog :border-width 10
35ec512c 245 :child (make-instance 'calendar)))
0d07716f 246
247
248;;; Check buttons
249
35ec512c 250(define-simple-dialog create-check-buttons (dialog "Check Buttons")
251 (make-instance 'v-box
6490e9f1 252 :border-width 10 :spacing 10 :parent dialog
35ec512c 253 :children (loop
254 for n from 1 to 3
255 collect (make-instance 'check-button
256 :label (format nil "Button~D" n)))))
0d07716f 257
258
259
260;;; Color selection
261
35ec512c 262(define-dialog create-color-selection (dialog "Color selection dialog"
263 'color-selection-dialog
6490e9f1 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)))))
35ec512c 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))))
0d07716f 287
35ec512c 288 (signal-connect dialog :cancel #'widget-destroy :object t)))
0d07716f 289
0d07716f 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
af5eb952 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)
8804934b 308 (widget-get-size-allocation drawing-area)
af5eb952 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
8f0159a6 330 :events '(:exposure :button-press)))
af5eb952 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)
45314d76 338 (1 (spin-button-spin spinner :step-forward))
339 (3 (spin-button-spin spinner :step-backward)))
af5eb952 340 t))
0d07716f 341
af5eb952 342 (signal-connect drawing-area 'scroll-event
343 #'(lambda (event)
344 (case (gdk:event-direction event)
45314d76 345 (:up (spin-button-spin spinner :step-forward))
346 (:down (spin-button-spin spinner :step-backward)))
af5eb952 347 t))
0d07716f 348
af5eb952 349 (signal-connect spinner 'changed
350 #'(lambda ()
351 (set-cursor spinner drawing-area label)))
0d07716f 352
af5eb952 353 (make-instance 'v-box
6490e9f1 354 :parent dialog :border-width 10 :spacing 5
af5eb952 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
af5eb952 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)))
0d07716f 370
371
372;;; Dialog
373
35ec512c 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))))))
0d07716f 393
35ec512c 394 (if (widget-visible-p dialog)
395 (widget-hide dialog)
396 (widget-show dialog))))
0d07716f 397
398
399;; Entry
400
35ec512c 401(define-simple-dialog create-entry (dialog "Entry")
402 (let ((main (make-instance 'v-box
403 :border-width 10 :spacing 10 :parent dialog)))
4fb50b71 404
35ec512c 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)
4fb50b71 410
e52cf822 411 (let ((combo (make-instance 'combo-box-entry
35ec512c 412 :parent main
e52cf822 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)))
35ec512c 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)
6490e9f1 438 (create-check-button "Sensitive" 'sensitive)))))
0d07716f 439
0d07716f 440
36c95ad8 441;; Expander
442
443(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
444 (make-instance 'v-box
6490e9f1 445 :parent dialog :spacing 5 :border-width 5
36c95ad8 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
0d07716f 451
35ec512c 452;; File chooser dialog
0d07716f 453
35ec512c 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 ()
ab652f5f 458 (if (slot-boundp dialog 'filename)
7c1f9a1e 459 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
460 (write-line "No files selected"))
35ec512c 461 (widget-destroy dialog))))
0d07716f 462
463
b9d3ad20 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
0d07716f 473
474;;; Handle box
475
ab652f5f 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")))
35ec512c 495
496;;; Image
0d07716f 497
35ec512c 498(define-toplevel create-image (window "Image")
499 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
0d07716f 500
501
502;;; Labels
503
35ec512c 504(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
4fb50b71 505 (flet ((create-label-in-frame (frame-label label-text &rest args)
506 (list
507 (make-instance 'frame
508 :label frame-label
35ec512c 509 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
4fb50b71 510 :fill nil :expand nil)))
35ec512c 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"
0d07716f 518"This is a Multi-line label.
519Second line
4fb50b71 520Third line")
35ec512c 521 :child (create-label-in-frame "Left Justified Label"
0d07716f 522"This is a Left-Justified
523Multi-line.
4fb50b71 524Third line"
35ec512c 525 :justify :left)
526 :child (create-label-in-frame "Right Justified Label"
0d07716f 527"This is a Right-Justified
528Multi-line.
4fb50b71 529Third line"
35ec512c 530 :justify :right))
531 :child (make-instance 'v-box
532 :spacing 5
533 :child (create-label-in-frame "Line wrapped label"
0d07716f 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.
4fb50b71 535 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
35ec512c 536 :wrap t)
537
538 :child (create-label-in-frame "Filled, wrapped label"
0d07716f 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.
4fb50b71 541 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
35ec512c 542 :justify :fill :wrap t)
543
544 :child (create-label-in-frame "Underlined label"
0d07716f 545"This label is underlined!
4fb50b71 546This one is underlined (こんにちは) in quite a funky fashion"
35ec512c 547 :justify :left
548 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
0d07716f 549
550
551;;; Layout
552
af5eb952 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)
35ec512c 572
573(define-toplevel create-layout (window "Layout" :default-width 200
574 :default-height 200)
4fb50b71 575 (let ((layout (make-instance 'layout
576 :parent (make-instance 'scrolled-window :parent window)
8f0159a6 577 :width 1600 :height 128000 :events '(:exposure)
6490e9f1 578 :signal (list 'expose-event #'layout-expose :object t))))
4fb50b71 579
580 (with-slots (hadjustment vadjustment) layout
581 (setf
582 (adjustment-step-increment hadjustment) 10.0
583 (adjustment-step-increment vadjustment) 10.0))
0d07716f 584
585 (dotimes (i 16)
586 (dotimes (j 16)
35ec512c 587 (let ((text (format nil "Button ~D, ~D" i j)))
6490e9f1 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)))))
0d07716f 594
35ec512c 595 (loop
596 for i from 16 below 1280
597 do (let ((text (format nil "Button ~D, ~D" i 0)))
6490e9f1 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))))))
4fb50b71 604
0d07716f 605
606
607;;; List
608
549265c1 609(define-simple-dialog create-list (dialog "List" :default-height 400)
744118a7 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)))
0d07716f 616
549265c1 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))
744118a7 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
6490e9f1 641 :parent dialog :border-width 10 :spacing 10
744118a7 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))))
0d07716f 698
699
700;; Menus
701
702(defun create-menu (depth tearoff)
703 (unless (zerop depth)
35ec512c 704 (let ((menu (make-instance 'menu)))
0d07716f 705 (when tearoff
35ec512c 706 (let ((menu-item (make-instance 'tearoff-menu-item)))
707 (menu-shell-append menu menu-item)))
0d07716f 708 (let ((group nil))
709 (dotimes (i 5)
35ec512c 710 (let ((menu-item
711 (make-instance 'radio-menu-item
712 :label (format nil "item ~2D - ~D" depth (1+ i)))))
713 (if group
ab652f5f 714 (add-to-radio-group menu-item group)
35ec512c 715 (setq group menu-item))
0d07716f 716 (unless (zerop (mod depth 2))
35ec512c 717 (setf (check-menu-item-active-p menu-item) t))
718 (menu-shell-append menu menu-item)
0d07716f 719 (when (= i 3)
35ec512c 720 (setf (widget-sensitive-p menu-item) nil))
8804934b 721 (let ((submenu (create-menu (1- depth) t)))
722 (when submenu
723 (setf (menu-item-submenu menu-item) submenu))))))
4fb50b71 724 menu)))
0d07716f 725
726
35ec512c 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))))
ab652f5f 731; (window-add-accel-group dialog accel-group)
35ec512c 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
e52cf822 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))))
0d07716f 754
e52cf822 755 (widget-show-all main)))
0d07716f 756
757
758;;; Notebook
759
8804934b 760(defun create-notebook-page (notebook page-num book-closed)
35ec512c 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
6490e9f1 800 :show-children t
35ec512c 801 :child-args '(:expand nil)
8804934b 802 :child (make-instance 'image :pixbuf book-closed)
35ec512c 803 :child (make-instance 'label :label title)))
804 (menu-box (make-instance 'h-box
6490e9f1 805 :show-children t
35ec512c 806 :child-args '(:expand nil)
8804934b 807 :child (make-instance 'image :pixbuf book-closed)
35ec512c 808 :child (make-instance 'label :label title))))
809
810 (widget-show-all page)
811 (notebook-append notebook page label-box menu-box))))
0d07716f 812
0d07716f 813
35ec512c 814(define-simple-dialog create-notebook (dialog "Notebook")
815 (let ((main (make-instance 'v-box :parent dialog)))
8804934b 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
35ec512c 819 :border-width 10 :tab-pos :top :parent main)))
8804934b 820 (flet ((set-image (page func pixbuf)
821 (setf
822 (image-pixbuf
823 (first (container-children (funcall func notebook page))))
824 pixbuf)))
35ec512c 825 (signal-connect notebook 'switch-page
826 #'(lambda (pointer page)
827 (declare (ignore pointer))
ab652f5f 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)
35ec512c 831 (let ((curpage (notebook-current-page notebook)))
ab652f5f 832 (set-image curpage #'notebook-menu-label book-closed)
833 (set-image curpage #'notebook-tab-label book-closed))))))
8804934b 834 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
35ec512c 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))
e52cf822 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
8804934b 890 do (create-notebook-page notebook i book-closed))))))
e52cf822 891 :object t)))
35ec512c 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)))
0d07716f 917
918
919;;; Panes
920
921(defun toggle-resize (child)
7c1f9a1e 922 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
0d07716f 923
924(defun toggle-shrink (child)
7c1f9a1e 925 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
0d07716f 926
927(defun create-pane-options (paned frame-label label1 label2)
7c1f9a1e 928 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
81f2aa93 929 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
35ec512c 930 (let ((check-button (make-instance 'check-button :label "Resize")))
81f2aa93 931 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 935 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
7c1f9a1e 936 (signal-connect check-button 'toggled
937 #'toggle-shrink :object (paned-child1 paned)))
0d07716f 938
81f2aa93 939 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
7c1f9a1e 940 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
81f2aa93 941 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 945 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
7c1f9a1e 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)))
0d07716f 949
35ec512c 950(define-toplevel create-panes (window "Panes")
951 (let* ((hpaned (make-instance 'h-paned
4fb50b71 952 :child1 (make-instance 'frame
35ec512c 953 :width-request 60 :height-request 60
954 :shadow-type :in
7c1f9a1e 955 :child (make-instance 'button :label "Hi there"))
35ec512c 956 :child2 (make-instance 'frame
957 :width-request 80 :height-request 60
958 :shadow-type :in)))
959 (vpaned (make-instance 'v-paned
4fb50b71 960 :border-width 5
961 :child1 hpaned
962 :child2 (make-instance 'frame
35ec512c 963 :width-request 80 :height-request 60
964 :shadow-type :in))))
4fb50b71 965
35ec512c 966 (make-instance 'v-box
4fb50b71 967 :parent window
35ec512c 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"))))
0d07716f 972
973
0d07716f 974;;; Progress bar
975
8804934b 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
6490e9f1 993 :parent dialog :border-width 10 :spacing 10
8804934b 994 :child progress
995 :child activity-mode-button)
996
997 (signal-connect dialog 'destroy
998 #'(lambda () (when timer (timeout-remove timer))))))
0d07716f 999
1000
1001;;; Radio buttons
1002
35ec512c 1003(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1004 (make-instance 'v-box
6490e9f1 1005 :parent dialog :border-width 10 :spacing 10
8179fd68 1006 :children (make-radio-group 'radio-button
1007 '((:label "button1") (:label "button2") (:label "button3"))
1008 nil)))
0d07716f 1009
1010
1011;;; Rangle controls
1012
35ec512c 1013(define-simple-dialog create-range-controls (dialog "Range controls")
0d07716f 1014 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
35ec512c 1015 (make-instance 'v-box
6490e9f1 1016 :parent dialog :border-width 10 :spacing 10
35ec512c 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))))
0d07716f 1022
1023
1024;;; Reparent test
1025
35ec512c 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))
8804934b 1029 (label (make-instance 'label :label "Hello World")))
0d07716f 1030
35ec512c 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)))
0d07716f 1041
35ec512c 1042 (box-pack-start (create-frame "Frame 1") label nil t 0)
1043 (create-frame "Frame 2"))
1044 (widget-show-all main)))
0d07716f 1045
1046
1047;;; Rulers
1048
35ec512c 1049(define-toplevel create-rulers (window "Rulers"
1050 :default-width 300 :default-height 300
8f0159a6 1051 :events '(:pointer-motion :pointer-motion-hint))
81f2aa93 1052 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1053 (h-ruler (make-instance 'h-ruler
35ec512c 1054 :metric :centimeters :lower 100.0d0 :upper 0.0d0
81f2aa93 1055 :position 0.0d0 :max-size 20.0d0))
1056 (v-ruler (make-instance 'v-ruler
35ec512c 1057 :lower 5.0d0 :upper 15.0d0
1058 :position 0.0d0 :max-size 20.0d0)))
81f2aa93 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)))
0d07716f 1065
1066
1067;;; Scrolled window
1068
35ec512c 1069(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1070 :default-width 300
1071 :default-height 300)
4fb50b71 1072 (let* ((scrolled-window
1073 (make-instance 'scrolled-window
35ec512c 1074 :parent dialog :border-width 10
1075 :vscrollbar-policy :automatic
4fb50b71 1076 :hscrollbar-policy :automatic))
1077 (table
1078 (make-instance 'table
35ec512c 1079 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
4fb50b71 1080 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1081 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
0d07716f 1082
0d07716f 1083 (scrolled-window-add-with-viewport scrolled-window table)
0d07716f 1084 (dotimes (i 20)
1085 (dotimes (j 20)
1086 (let ((button
35ec512c 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)))
0d07716f 1091
1092
81f2aa93 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
6490e9f1 1114 :parent dialog :border-width 5 :spacing 5
81f2aa93 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
0d07716f 1129;;; Shapes
1130
83bab9b6 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))))
4fb50b71 1137
83bab9b6 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))
4fb50b71 1143
83bab9b6 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)))
0d07716f 1161
83bab9b6 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))))))
0d07716f 1169
83bab9b6 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)))))
0d07716f 1203
1204
1205
1206;;; Spin buttons
1207
35ec512c 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 : "
5ff67599 1228 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
35ec512c 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)))
0d07716f 1304
35ec512c 1305
5ff67599 1306;;; Statusbar
0d07716f 1307
5ff67599 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)))
0d07716f 1342
1343
1344;;; Idle test
1345
e025589b 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))))
0d07716f 1353
e025589b 1354 (make-instance 'v-box
6490e9f1 1355 :parent dialog :border-width 10 :spacing 10
e025589b 1356 :child label
1357 :child (make-instance 'frame
1358 :label "Label Container" :border-width 5
1359 :child(make-instance 'v-box
8179fd68 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))
e025589b 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))))))
0d07716f 1377
e025589b 1378 (dialog-add-button dialog "Stop"
1379 #'(lambda ()
1380 (when idle
1381 (idle-remove idle)
1382 (setq idle nil))))))
0d07716f 1383
1384
1385
1386;;; Timeout test
1387
e025589b 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))))))
7932cfab 1411
1412
1413;;; Text
1414
1415(define-simple-dialog create-text (dialog "Text" :default-width 400
1416 :default-height 400)
81f2aa93 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)))
ab652f5f 1435 (multiple-value-bind (non-zero-p start end)
1436 (text-buffer-get-selection-bounds buffer)
6490e9f1 1437 (declare (ignore non-zero-p))
81f2aa93 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
0d07716f 1498
0d07716f 1499;;; Toggle buttons
1500
35ec512c 1501(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1502 (make-instance 'v-box
6490e9f1 1503 :border-width 10 :spacing 10 :parent dialog
35ec512c 1504 :children (loop
1505 for n from 1 to 3
1506 collect (make-instance 'toggle-button
1507 :label (format nil "Button~D" (1+ n))))))
0d07716f 1508
1509
1510
1511;;; Toolbar test
1512
ab652f5f 1513(defun create-toolbar (window)
8179fd68 1514 (make-instance 'toolbar
ab652f5f 1515 :show-tooltips t :show-arrow nil
8179fd68 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 ))
0d07716f 1598
ab652f5f 1599(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1600 (container-add window (create-toolbar window)))
1601
0d07716f 1602
1603
1604;;; Tooltips test
1605
e025589b 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
6490e9f1 1613 :parent dialog :border-width 10 :spacing 10
e025589b 1614 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
7c1f9a1e 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")))))
7932cfab 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
81f2aa93 1647(define-toplevel create-ui-manager (window "UI Manager")
7932cfab 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")
81f2aa93 1657 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
7932cfab 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")
81f2aa93 1660 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
7932cfab 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
81f2aa93 1678 (window-add-accel-group window (ui-manager-accel-group ui))
7932cfab 1679
1680 (make-instance 'v-box
6490e9f1 1681 :parent window
7932cfab 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))))
0d07716f 1692
1693
1694
0d07716f 1695;;; Main window
1696
1697(defun create-main-window ()
35ec512c 1698;; (rc-parse "clg:examples;testgtkrc2")
1699;; (rc-parse "clg:examples;testgtkrc")
4fb50b71 1700
1701 (let* ((button-specs
0d07716f 1702 '(("button box" create-button-box)
35ec512c 1703 ("buttons" create-buttons)
1704 ("calendar" create-calendar)
1705 ("check buttons" create-check-buttons)
35ec512c 1706 ("color selection" create-color-selection)
af5eb952 1707 ("cursors" create-cursors)
35ec512c 1708 ("dialog" create-dialog)
1709;; ; ("dnd")
1710 ("entry" create-entry)
1711;; ("event watcher")
36c95ad8 1712 ("enxpander" create-expander)
35ec512c 1713 ("file chooser" create-file-chooser)
b9d3ad20 1714 ("font selection" create-font-selection)
ab652f5f 1715 ("handle box" create-handle-box)
35ec512c 1716 ("image" create-image)
35ec512c 1717 ("labels" create-labels)
1718 ("layout" create-layout)
549265c1 1719 ("list" create-list)
0d07716f 1720 ("menus" create-menus)
35ec512c 1721;; ("modal window")
1722 ("notebook" create-notebook)
1723 ("panes" create-panes)
8804934b 1724 ("progress bar" create-progress-bar)
35ec512c 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)
81f2aa93 1732 ("size group" create-size-group)
83bab9b6 1733 ("shapes" create-shapes)
35ec512c 1734 ("spinbutton" create-spins)
5ff67599 1735 ("statusbar" create-statusbar)
e025589b 1736 ("test idle" create-idle-test)
35ec512c 1737;; ("test mainloop")
1738;; ("test scrolling")
1739;; ("test selection")
e025589b 1740 ("test timeout" create-timeout-test)
7932cfab 1741 ("text" create-text)
35ec512c 1742 ("toggle buttons" create-toggle-buttons)
ab652f5f 1743 ("toolbar" create-toolbar-window)
e025589b 1744 ("tooltips" create-tooltips)
35ec512c 1745;; ("tree" #|create-tree|#)
7932cfab 1746 ("UI manager" create-ui-manager)
35ec512c 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))))
0d07716f 1760
8804934b 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)))
7c1f9a1e 1765
0d07716f 1766 ;; Main box
35ec512c 1767 (make-instance 'v-box
0d07716f 1768 :parent main-window
35ec512c 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))
0d07716f 1785
35ec512c 1786 (widget-grab-focus close-button)
0d07716f 1787 (widget-show-all main-window)
1788 main-window))
1789
35ec512c 1790(clg-init)
1791(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).