chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Automatic definition of EVENT-MASK overridden with manual definition
[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
4280ef98 18;; $Id: testgtk.lisp,v 1.19 2005-02-26 10:44:11 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
464
465;;; Handle box
466
842e5ffe 467(define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
468 (make-instance 'v-box
469 :parent window
470 :child (create-label "Above")
471 :child (make-instance 'h-separator)
472 :child (make-instance 'h-box
473 :spacing 10
474 :child (list
475 (make-instance 'handle-box
476 :child (create-toolbar window)
477 :signal (list 'child-attached
478 #'(lambda (child)
479 (format t "~A attached~%" child)))
480 :signal (list 'child-detached
481 #'(lambda (child)
482 (format t "~A detached~%" child))))
483 :expand nil :fill :nil))
484 :child (make-instance 'h-separator)
485 :child (create-label "Below")))
704a1de4 486
487;;; Image
560af5c5 488
704a1de4 489(define-toplevel create-image (window "Image")
490 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5 491
492
493;;; Labels
494
704a1de4 495(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9 496 (flet ((create-label-in-frame (frame-label label-text &rest args)
497 (list
498 (make-instance 'frame
499 :label frame-label
704a1de4 500 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
196fe1e9 501 :fill nil :expand nil)))
704a1de4 502 (make-instance 'h-box
503 :spacing 5 :parent window
504 :child-args '(:fill nil :expand nil)
505 :child (make-instance 'v-box
506 :spacing 5
507 :child (create-label-in-frame "Normal Label" "This is a Normal label")
508 :child (create-label-in-frame "Multi-line Label"
560af5c5 509"This is a Multi-line label.
510Second line
196fe1e9 511Third line")
704a1de4 512 :child (create-label-in-frame "Left Justified Label"
560af5c5 513"This is a Left-Justified
514Multi-line.
196fe1e9 515Third line"
704a1de4 516 :justify :left)
517 :child (create-label-in-frame "Right Justified Label"
560af5c5 518"This is a Right-Justified
519Multi-line.
196fe1e9 520Third line"
704a1de4 521 :justify :right))
522 :child (make-instance 'v-box
523 :spacing 5
524 :child (create-label-in-frame "Line wrapped label"
560af5c5 525"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 526 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4 527 :wrap t)
528
529 :child (create-label-in-frame "Filled, wrapped label"
560af5c5 530"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.
531 This is a new paragraph.
196fe1e9 532 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4 533 :justify :fill :wrap t)
534
535 :child (create-label-in-frame "Underlined label"
560af5c5 536"This label is underlined!
196fe1e9 537This one is underlined (こんにちは) in quite a funky fashion"
704a1de4 538 :justify :left
539 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
560af5c5 540
541
542;;; Layout
543
aa9ceddc 544(defun layout-expose (layout event)
545 (when (eq (gdk:event-window event) (layout-bin-window layout))
546 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
547 (let ((imin (truncate gdk:x 10))
548 (imax (truncate (+ gdk:x gdk:width 9) 10))
549 (jmin (truncate gdk:y 10))
550 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
551
552 (let ((window (layout-bin-window layout))
553 (gc (style-black-gc (widget-style layout))))
554 (loop
555 for i from imin below imax
556 do (loop
557 for j from jmin below jmax
558 unless (zerop (mod (+ i j) 2))
559 do (gdk:draw-rectangle
560 window gc t (* 10 i) (* 10 j)
561 (1+ (mod i 10)) (1+ (mod j 10)))))))))
562 nil)
704a1de4 563
564(define-toplevel create-layout (window "Layout" :default-width 200
565 :default-height 200)
196fe1e9 566 (let ((layout (make-instance 'layout
567 :parent (make-instance 'scrolled-window :parent window)
4280ef98 568 :width 1600 :height 128000 :events '(:exposure)
f6ebddea 569 :signal (list 'expose-event #'layout-expose :object t))))
196fe1e9 570
571 (with-slots (hadjustment vadjustment) layout
572 (setf
573 (adjustment-step-increment hadjustment) 10.0
574 (adjustment-step-increment vadjustment) 10.0))
560af5c5 575
576 (dotimes (i 16)
577 (dotimes (j 16)
704a1de4 578 (let ((text (format nil "Button ~D, ~D" i j)))
f6ebddea 579 (layout-put layout
580 (make-instance (if (not (zerop (mod (+ i j) 2)))
581 'button
582 'label)
583 :label text :visible t)
584 (* j 100) (* i 100)))))
560af5c5 585
704a1de4 586 (loop
587 for i from 16 below 1280
588 do (let ((text (format nil "Button ~D, ~D" i 0)))
f6ebddea 589 (layout-put layout
590 (make-instance (if (not (zerop (mod i 2)))
591 'button
592 'label)
593 :label text :visible t)
594 0 (* i 100))))))
196fe1e9 595
560af5c5 596
597
598;;; List
599
21f6214a 600(define-simple-dialog create-list (dialog "List" :default-height 400)
d975a970 601 (let* ((store (make-instance 'list-store
602 :column-types '(string int boolean)
603 :column-names '(:foo :bar :baz)
604 :initial-content '(#("First" 12321 nil)
605 (:foo "Yeah" :baz t))))
606 (tree (make-instance 'tree-view :model store)))
560af5c5 607
21f6214a 608 (loop
609 with iter = (make-instance 'tree-iter)
610 for i from 1 to 1000
611 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
d975a970 612
613 (let ((column (make-instance 'tree-view-column :title "Column 1"))
614 (cell (make-instance 'cell-renderer-text)))
615 (cell-layout-pack column cell :expand t)
616 (cell-layout-add-attribute column cell 'text (column-index store :foo))
617 (tree-view-append-column tree column))
618
619 (let ((column (make-instance 'tree-view-column :title "Column 2"))
620 (cell (make-instance 'cell-renderer-text :background "orange")))
621 (cell-layout-pack column cell :expand t)
622 (cell-layout-add-attribute column cell 'text (column-index store :bar))
623 (tree-view-append-column tree column))
624
625 (let ((column (make-instance 'tree-view-column :title "Column 3"))
626 (cell (make-instance 'cell-renderer-text)))
627 (cell-layout-pack column cell :expand t)
628 (cell-layout-add-attribute column cell 'text (column-index store :baz))
629 (tree-view-append-column tree column))
630
631 (make-instance 'v-box
f6ebddea 632 :parent dialog :border-width 10 :spacing 10
d975a970 633 :child (list
634 (make-instance 'h-box
635 :spacing 10
636 :child (make-instance 'button
637 :label "Remove Selection"
638 :signal (list 'clicked
639 #'(lambda ()
640 (let ((references
641 (mapcar
642 #'(lambda (path)
643 (make-instance 'tree-row-reference :model store :path path))
644 (tree-selection-get-selected-rows
645 (tree-view-selection tree)))))
646 (mapc
647 #'(lambda (reference)
648 (list-store-remove store reference))
649 references))))))
650 :expand nil)
651 :child (list
652 (make-instance 'h-box
653 :spacing 10
654 :child (make-instance 'check-button
655 :label "Show Headers" :active t
656 :signal (list 'toggled
657 #'(lambda (button)
658 (setf
659 (tree-view-headers-visible-p tree)
660 (toggle-button-active-p button)))
661 :object t))
662 :child (make-instance 'check-button
663 :label "Reorderable" :active nil
664 :signal (list 'toggled
665 #'(lambda (button)
666 (setf
667 (tree-view-reorderable-p tree)
668 (toggle-button-active-p button)))
669 :object t))
670 :child (list
671 (make-instance 'h-box
672 :child (make-instance 'label :label "Selection Mode: ")
673 :child (make-instance 'combo-box
674 :content '("Single" "Browse" "Multiple")
675 :active 0
676 :signal (list 'changed
677 #'(lambda (combo-box)
678 (setf
679 (tree-selection-mode
680 (tree-view-selection tree))
681 (svref
682 #(:single :browse :multiple)
683 (combo-box-active combo-box))))
684 :object t)))
685 :expand nil))
686 :expand nil)
687 :child (make-instance 'scrolled-window
688 :child tree :hscrollbar-policy :automatic))))
560af5c5 689
690
691;; Menus
692
693(defun create-menu (depth tearoff)
694 (unless (zerop depth)
704a1de4 695 (let ((menu (make-instance 'menu)))
560af5c5 696 (when tearoff
704a1de4 697 (let ((menu-item (make-instance 'tearoff-menu-item)))
698 (menu-shell-append menu menu-item)))
560af5c5 699 (let ((group nil))
700 (dotimes (i 5)
704a1de4 701 (let ((menu-item
702 (make-instance 'radio-menu-item
703 :label (format nil "item ~2D - ~D" depth (1+ i)))))
704 (if group
842e5ffe 705 (add-to-radio-group menu-item group)
704a1de4 706 (setq group menu-item))
560af5c5 707 (unless (zerop (mod depth 2))
704a1de4 708 (setf (check-menu-item-active-p menu-item) t))
709 (menu-shell-append menu menu-item)
560af5c5 710 (when (= i 3)
704a1de4 711 (setf (widget-sensitive-p menu-item) nil))
977a550d 712 (let ((submenu (create-menu (1- depth) t)))
713 (when submenu
714 (setf (menu-item-submenu menu-item) submenu))))))
196fe1e9 715 menu)))
560af5c5 716
717
704a1de4 718(define-simple-dialog create-menus (dialog "Menus" :default-width 200)
719 (let* ((main (make-instance 'v-box :parent dialog))
720; (accel-group (make-instance 'accel-group))
721 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
842e5ffe 722; (window-add-accel-group dialog accel-group)
704a1de4 723
724 (let ((menu-item (make-instance 'menu-item
725 :label (format nil "test~%line2"))))
726 (setf (menu-item-submenu menu-item) (create-menu 2 t))
727 (menu-shell-append menubar menu-item))
728
729 (let ((menu-item (make-instance 'menu-item :label "foo")))
730 (setf (menu-item-submenu menu-item) (create-menu 3 t))
731 (menu-shell-append menubar menu-item))
732
733 (let ((menu-item (make-instance 'menu-item :label "bar")))
734 (setf (menu-item-submenu menu-item) (create-menu 4 t))
735 (setf (menu-item-right-justified-p menu-item) t)
736 (menu-shell-append menubar menu-item))
737
613fb570 738 (make-instance 'v-box
739 :spacing 10 :border-width 10 :parent main
740 :child (make-instance 'combo-box
741 :active 3
742 :content (loop
743 for i from 1 to 5
744 collect (format nil "Item ~D" i))))
560af5c5 745
613fb570 746 (widget-show-all main)))
560af5c5 747
748
749;;; Notebook
750
977a550d 751(defun create-notebook-page (notebook page-num book-closed)
704a1de4 752 (let* ((title (format nil "Page ~D" page-num))
753 (page (make-instance 'frame :label title :border-width 10))
754 (v-box (make-instance 'v-box
755 :homogeneous t :border-width 10 :parent page)))
756
757 (make-instance 'h-box
758 :parent (list v-box :fill nil :padding 5) :homogeneous t
759 :child-args '(:padding 5)
760 :child (make-instance 'check-button
761 :label "Fill Tab" :active t
762 :signal (list 'toggled
763 #'(lambda (button)
764 (setf
765 (notebook-child-tab-fill-p page)
766 (toggle-button-active-p button)))
767 :object t))
768 :child (make-instance 'check-button
769 :label "Expand Tab"
770 :signal (list 'toggled
771 #'(lambda (button)
772 (setf
773 (notebook-child-tab-expand-p page)
774 (toggle-button-active-p button)))
775 :object t))
776 :child (make-instance 'check-button
777 :label "Pack end"
778 :signal (list 'toggled
779 #'(lambda (button)
780 (setf
781 (notebook-child-tab-pack page)
782 (if (toggle-button-active-p button)
783 :end
784 :start)))
785 :object t))
786 :child (make-instance 'button
787 :label "Hide page"
788 :signal (list 'clicked #'(lambda () (widget-hide page)))))
789
790 (let ((label-box (make-instance 'h-box
f6ebddea 791 :show-children t
704a1de4 792 :child-args '(:expand nil)
977a550d 793 :child (make-instance 'image :pixbuf book-closed)
704a1de4 794 :child (make-instance 'label :label title)))
795 (menu-box (make-instance 'h-box
f6ebddea 796 :show-children t
704a1de4 797 :child-args '(:expand nil)
977a550d 798 :child (make-instance 'image :pixbuf book-closed)
704a1de4 799 :child (make-instance 'label :label title))))
800
801 (widget-show-all page)
802 (notebook-append notebook page label-box menu-box))))
560af5c5 803
560af5c5 804
704a1de4 805(define-simple-dialog create-notebook (dialog "Notebook")
806 (let ((main (make-instance 'v-box :parent dialog)))
977a550d 807 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
808 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
809 (notebook (make-instance 'notebook
704a1de4 810 :border-width 10 :tab-pos :top :parent main)))
977a550d 811 (flet ((set-image (page func pixbuf)
812 (setf
813 (image-pixbuf
814 (first (container-children (funcall func notebook page))))
815 pixbuf)))
704a1de4 816 (signal-connect notebook 'switch-page
817 #'(lambda (pointer page)
818 (declare (ignore pointer))
842e5ffe 819 (set-image page #'notebook-menu-label book-open)
820 (set-image page #'notebook-tab-label book-open)
821 (when (slot-boundp notebook 'current-page)
704a1de4 822 (let ((curpage (notebook-current-page notebook)))
842e5ffe 823 (set-image curpage #'notebook-menu-label book-closed)
824 (set-image curpage #'notebook-tab-label book-closed))))))
977a550d 825 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
704a1de4 826
827 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
828
829 (make-instance 'h-box
830 :spacing 5 :border-width 10
831 :parent (list main :expand nil)
832 :child-args '(:fill nil)
833 :child (make-instance 'check-button
834 :label "Popup menu"
835 :signal (list 'clicked
836 #'(lambda (button)
837 (if (toggle-button-active-p button)
838 (notebook-popup-enable notebook)
839 (notebook-popup-disable notebook)))
840 :object t))
841 :child (make-instance 'check-button
842 :label "Homogeneous tabs"
843 :signal (list 'clicked
844 #'(lambda (button)
845 (setf
846 (notebook-homogeneous-p notebook)
847 (toggle-button-active-p button)))
848 :object t)))
849
850 (make-instance 'h-box
851 :spacing 5 :border-width 10
852 :parent (list main :expand nil)
853 :child-args '(:expand nil)
854 :child (make-instance 'label :label "Notebook Style: ")
855 :child (let ((scrollable-p nil))
613fb570 856 (make-instance 'combo-box
857 :content '("Standard" "No tabs" "Scrollable") :active 0
858 :signal (list 'changed
859 #'(lambda (combo-box)
860 (case (combo-box-active combo-box)
861 (0
862 (setf (notebook-show-tabs-p notebook) t)
863 (when scrollable-p
864 (setq scrollable-p nil)
865 (setf (notebook-scrollable-p notebook) nil)
866 (loop repeat 10
867 do (notebook-remove-page notebook 5))))
868 (1
869 (setf (notebook-show-tabs-p notebook) nil)
870 (when scrollable-p
871 (setq scrollable-p nil)
872 (setf (notebook-scrollable-p notebook) nil)
873 (loop repeat 10
874 do (notebook-remove-page notebook 5))))
875 (2
876 (unless scrollable-p
877 (setq scrollable-p t)
878 (setf (notebook-show-tabs-p notebook) t)
879 (setf (notebook-scrollable-p notebook) t)
880 (loop for i from 6 to 15
977a550d 881 do (create-notebook-page notebook i book-closed))))))
613fb570 882 :object t)))
704a1de4 883 :child (make-instance 'button
884 :label "Show all Pages"
885 :signal (list 'clicked
886 #'(lambda ()
887 (map-container nil #'widget-show notebook)))))
888
889 (make-instance 'h-box
890 :spacing 5 :border-width 10
891 :parent (list main :expand nil)
892 :child (make-instance 'button
893 :label "prev"
894 :signal (list 'clicked #'notebook-prev-page :object notebook))
895 :child (make-instance 'button
896 :label "next"
897 :signal (list 'clicked #'notebook-next-page :object notebook))
898 :child (make-instance 'button
899 :label "rotate"
900 :signal (let ((tab-pos 0))
901 (list 'clicked
902 #'(lambda ()
903 (setq tab-pos (mod (1+ tab-pos) 4))
904 (setf
905 (notebook-tab-pos notebook)
906 (svref #(:top :right :bottom :left) tab-pos))))))))
907 (widget-show-all main)))
560af5c5 908
909
910;;; Panes
911
912(defun toggle-resize (child)
812dd869 913 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
560af5c5 914
915(defun toggle-shrink (child)
812dd869 916 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
560af5c5 917
918(defun create-pane-options (paned frame-label label1 label2)
812dd869 919 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
33f468b7 920 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
704a1de4 921 (let ((check-button (make-instance 'check-button :label "Resize")))
33f468b7 922 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
812dd869 923 (signal-connect check-button 'toggled
924 #'toggle-resize :object (paned-child1 paned)))
925 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
33f468b7 926 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
812dd869 927 (signal-connect check-button 'toggled
928 #'toggle-shrink :object (paned-child1 paned)))
560af5c5 929
33f468b7 930 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
812dd869 931 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
33f468b7 932 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
812dd869 933 (signal-connect check-button 'toggled
934 #'toggle-resize :object (paned-child2 paned)))
935 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
33f468b7 936 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
812dd869 937 (signal-connect check-button 'toggled
938 #'toggle-shrink :object (paned-child2 paned)))
939 (make-instance 'frame :label frame-label :border-width 4 :child table)))
560af5c5 940
704a1de4 941(define-toplevel create-panes (window "Panes")
942 (let* ((hpaned (make-instance 'h-paned
196fe1e9 943 :child1 (make-instance 'frame
704a1de4 944 :width-request 60 :height-request 60
945 :shadow-type :in
812dd869 946 :child (make-instance 'button :label "Hi there"))
704a1de4 947 :child2 (make-instance 'frame
948 :width-request 80 :height-request 60
949 :shadow-type :in)))
950 (vpaned (make-instance 'v-paned
196fe1e9 951 :border-width 5
952 :child1 hpaned
953 :child2 (make-instance 'frame
704a1de4 954 :width-request 80 :height-request 60
955 :shadow-type :in))))
196fe1e9 956
704a1de4 957 (make-instance 'v-box
196fe1e9 958 :parent window
704a1de4 959 :child-args '(:expand nil)
960 :child (list vpaned :expand t)
961 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
962 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
560af5c5 963
964
560af5c5 965;;; Progress bar
966
977a550d 967(define-simple-dialog create-progress-bar (dialog "Progress Bar")
968 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
969 (activity-mode-button (make-instance 'check-button
970 :label "Activity mode"))
971 (timer (timeout-add 100
972 #'(lambda ()
973 (if (toggle-button-active-p activity-mode-button)
974 (progress-bar-pulse progress)
975 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
976 (setf
977 (progress-bar-fraction progress)
978 (if (> fract 1.0)
979 0.0
980 fract))))
981 t))))
982
983 (make-instance 'v-box
f6ebddea 984 :parent dialog :border-width 10 :spacing 10
977a550d 985 :child progress
986 :child activity-mode-button)
987
988 (signal-connect dialog 'destroy
989 #'(lambda () (when timer (timeout-remove timer))))))
560af5c5 990
991
992;;; Radio buttons
993
704a1de4 994(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
995 (make-instance 'v-box
f6ebddea 996 :parent dialog :border-width 10 :spacing 10
787721b6 997 :children (make-radio-group 'radio-button
998 '((:label "button1") (:label "button2") (:label "button3"))
999 nil)))
560af5c5 1000
1001
1002;;; Rangle controls
1003
704a1de4 1004(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1005 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 1006 (make-instance 'v-box
f6ebddea 1007 :parent dialog :border-width 10 :spacing 10
704a1de4 1008 :child (make-instance 'h-scale
1009 :width-request 150 :adjustment adjustment :inverted t
1010 :update-policy :delayed :digits 1 :draw-value t)
1011 :child (make-instance 'h-scrollbar
1012 :adjustment adjustment :update-policy :continuous))))
560af5c5 1013
1014
1015;;; Reparent test
1016
704a1de4 1017(define-simple-dialog create-reparent (dialog "Reparent")
1018 (let ((main (make-instance 'h-box
1019 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
977a550d 1020 (label (make-instance 'label :label "Hello World")))
560af5c5 1021
704a1de4 1022 (flet ((create-frame (title)
1023 (let* ((frame (make-instance 'frame :label title :parent main))
1024 (box (make-instance 'v-box
1025 :spacing 5 :border-width 5 :parent frame))
1026 (button (make-instance 'button
1027 :label "switch" :parent (list box :expand nil))))
1028 (signal-connect button 'clicked
1029 #'(lambda ()
1030 (widget-reparent label box)))
1031 box)))
560af5c5 1032
704a1de4 1033 (box-pack-start (create-frame "Frame 1") label nil t 0)
1034 (create-frame "Frame 2"))
1035 (widget-show-all main)))
560af5c5 1036
1037
1038;;; Rulers
1039
704a1de4 1040(define-toplevel create-rulers (window "Rulers"
1041 :default-width 300 :default-height 300
4280ef98 1042 :events '(:pointer-motion :pointer-motion-hint))
33f468b7 1043 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1044 (h-ruler (make-instance 'h-ruler
704a1de4 1045 :metric :centimeters :lower 100.0d0 :upper 0.0d0
33f468b7 1046 :position 0.0d0 :max-size 20.0d0))
1047 (v-ruler (make-instance 'v-ruler
704a1de4 1048 :lower 5.0d0 :upper 15.0d0
1049 :position 0.0d0 :max-size 20.0d0)))
33f468b7 1050 (signal-connect window 'motion-notify-event
1051 #'(lambda (event)
1052 (widget-event h-ruler event)
1053 (widget-event v-ruler event)))
1054 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1055 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
560af5c5 1056
1057
1058;;; Scrolled window
1059
704a1de4 1060(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1061 :default-width 300
1062 :default-height 300)
196fe1e9 1063 (let* ((scrolled-window
1064 (make-instance 'scrolled-window
704a1de4 1065 :parent dialog :border-width 10
1066 :vscrollbar-policy :automatic
196fe1e9 1067 :hscrollbar-policy :automatic))
1068 (table
1069 (make-instance 'table
704a1de4 1070 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1071 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1072 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1073
560af5c5 1074 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1075 (dotimes (i 20)
1076 (dotimes (j 20)
1077 (let ((button
704a1de4 1078 (make-instance 'toggle-button
1079 :label (format nil "button (~D,~D)~%" i j))))
1080 (table-attach table button i (1+ i) j (1+ j)))))
1081 (widget-show-all scrolled-window)))
560af5c5 1082
1083
33f468b7 1084;;; Size group
1085
1086(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1087 (let ((size-group (make-instance 'size-group)))
1088 (flet ((create-frame (label rows)
1089 (let ((table (make-instance 'table
1090 :n-rows (length rows) :n-columns 2 :homogeneous nil
1091 :row-spacing 5 :column-spacing 10 :border-width 5)))
1092 (loop
1093 for row in rows
1094 for i from 0
1095 do (table-attach table
1096 (create-label (first row) :xalign 0 :yalign 1)
1097 0 1 i (1+ i) :x-options '(:expand :fill))
1098 (let ((combo (make-instance 'combo-box
1099 :content (rest row) :active 0)))
1100 (size-group-add-widget size-group combo)
1101 (table-attach table combo 1 2 i (1+ i))))
1102 (make-instance 'frame :label label :child table))))
1103
1104 (make-instance 'v-box
f6ebddea 1105 :parent dialog :border-width 5 :spacing 5
33f468b7 1106 :child (create-frame "Color Options"
1107 '(("Foreground" "Red" "Green" "Blue")
1108 ("Background" "Red" "Green" "Blue")))
1109 :child (create-frame "Line Options"
1110 '(("Dashing" "Solid" "Dashed" "Dotted")
1111 ("Line ends" "Square" "Round" "Arrow")))
1112 :child (create-check-button "Enable grouping"
1113 #'(lambda (active)
1114 (setf
1115 (size-group-mode size-group)
1116 (if active :horizontal :none)))
1117 t)))))
1118
1119
560af5c5 1120;;; Shapes
1121
704a1de4 1122;; (defun shape-create-icon (xpm-file x y px py type root-window destroy)
1123;; (let* ((window
1124;; (make-instance 'window
1125;; :type type :x x :y y
1126;; :events '(:button-motion :pointer-motion-hint :button-press)))
1127;; (fixed
1128;; (make-instance 'fixed
1129;; :parent window :width 100 :height 100)))
196fe1e9 1130
704a1de4 1131;; (widget-realize window)
1132;; (multiple-value-bind (source mask) nil ;(gdk:pixmap-create xpm-file)
1133;; (let ((pixmap (pixmap-new source mask))
1134;; (x-offset 0)
1135;; (y-offset 0))
1136;; (declare (fixnum x-offset y-offset))
1137;; (fixed-put fixed pixmap px py)
1138;; (widget-shape-combine-mask window mask px py)
196fe1e9 1139
704a1de4 1140;; (signal-connect window 'button-press-event
1141;; #'(lambda (event)
1142;; (when (typep event 'gdk:button-press-event)
1143;; (setq x-offset (truncate (gdk:event-x event)))
1144;; (setq y-offset (truncate (gdk:event-y event)))
1145;; (grab-add window)
1146;; (gdk:pointer-grab
1147;; (widget-window window) t
1148;; '(:button-release :button-motion :pointer-motion-hint)
1149;; nil nil 0))
1150;; t))
1151
1152;; (signal-connect window 'button-release-event
1153;; #'(lambda (event)
1154;; (declare (ignore event))
1155;; (grab-remove window)
1156;; (gdk:pointer-ungrab 0)
1157;; t))
560af5c5 1158
704a1de4 1159;; (signal-connect window 'motion-notify-event
1160;; #'(lambda (event)
1161;; (declare (ignore event))
1162;; (multiple-value-bind (win xp yp mask)
1163;; (gdk:window-get-pointer root-window)
1164;; (declare (ignore mask win) (fixnum xp yp))
1165;; (widget-set-uposition
1166;; window :x (- xp x-offset) :y (- yp y-offset)))
1167;; t))
1168;; (signal-connect window 'destroy destroy)))
560af5c5 1169
704a1de4 1170;; (widget-show-all window)
1171;; window))
1172
1173
1174;; (let ((modeller nil)
1175;; (sheets nil)
1176;; (rings nil))
1177;; (defun create-shapes ()
1178;; (let ((root-window (gdk:get-root-window)))
1179;; (if (not modeller)
1180;; (setq
1181;; modeller
1182;; (shape-create-icon
1183;; "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1184;; #'(lambda () (widget-destroyed modeller))))
1185;; (widget-destroy modeller))
1186
1187;; (if (not sheets)
1188;; (setq
1189;; sheets
1190;; (shape-create-icon
1191;; "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1192;; #'(lambda () (widget-destroyed sheets))))
1193;; (widget-destroy sheets))
1194
1195;; (if (not rings)
1196;; (setq
1197;; rings
1198;; (shape-create-icon
1199;; "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1200;; #'(lambda () (widget-destroyed rings))))
1201;; (widget-destroy rings)))))
560af5c5 1202
1203
1204
1205;;; Spin buttons
1206
704a1de4 1207(define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1208 (let ((main (make-instance 'v-box
1209 :spacing 5 :border-width 10 :parent dialog)))
1210
1211 (flet ((create-date-spinner (label adjustment shadow-type)
1212 (declare (ignore shadow-type))
1213 (make-instance 'v-box
1214 :child-args '(:expand nil)
1215 :child (make-instance 'label
1216 :label label :xalign 0.0 :yalign 0.5)
1217 :child (make-instance 'spin-button
1218 :adjustment adjustment :wrap t))))
1219 (make-instance 'frame
1220 :label "Not accelerated" :parent main
1221 :child (make-instance 'h-box
1222 :border-width 10
1223 :child-args '(:padding 5)
1224 :child (create-date-spinner "Day : "
1225 (adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0) :out)
1226 :child (create-date-spinner "Month : "
c775862e 1227 (adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0) :etched-in)
704a1de4 1228 :child (create-date-spinner "Year : "
1229 (adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0) :in))))
1230
1231 (let ((spinner1 (make-instance 'spin-button
1232 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1233 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1234 (spinner2 (make-instance 'spin-button
1235 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1236 :climb-rate 1.0 :wrap t))
1237 (value-label (make-instance 'label :label "0")))
1238 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1239 #'(lambda ()
1240 (setf
1241 (spin-button-digits spinner1)
1242 (floor (spin-button-value spinner2)))))
1243
1244 (make-instance 'frame
1245 :label "Accelerated" :parent main
1246 :child (make-instance 'v-box
1247 :border-width 5
1248 :child (list
1249 (make-instance 'h-box
1250 :child-args '(:padding 5)
1251 :child (make-instance 'v-box
1252 :child (make-instance 'label
1253 :label "Value :"
1254 :xalign 0.0 :yalign 0.5)
1255 :child spinner1)
1256 :child (make-instance 'v-box
1257 :child (make-instance 'label
1258 :label "Digits :"
1259 :xalign 0.0 :yalign 0.5)
1260 :child spinner2))
1261 :expand nil :padding 5)
1262 :child (make-instance 'check-button
1263 :label "Snap to 0.5-ticks" :active t
1264 :signal (list 'clicked
1265 #'(lambda (button)
1266 (setf
1267 (spin-button-snap-to-ticks-p spinner1)
1268 (toggle-button-active-p button)))
1269 :object t))
1270 :child (make-instance 'check-button
1271 :label "Numeric only input mode" :active t
1272 :signal (list 'clicked
1273 #'(lambda (button)
1274 (setf
1275 (spin-button-numeric-p spinner1)
1276 (toggle-button-active-p button)))
1277 :object t))
1278 :child value-label
1279 :child (list
1280 (make-instance 'h-box
1281 :child-args '(:padding 5)
1282 :child (make-instance 'button
1283 :label "Value as Int"
1284 :signal (list 'clicked
1285 #'(lambda ()
1286 (setf
1287 (label-label value-label)
1288 (format nil "~D"
1289 (spin-button-value-as-int
1290 spinner1))))))
1291 :child (make-instance 'button
1292 :label "Value as Float"
1293 :signal (list 'clicked
1294 #'(lambda ()
1295 (setf
1296 (label-label value-label)
1297 (format nil
1298 (format nil "~~,~DF"
1299 (spin-button-digits spinner1))
1300 (spin-button-value spinner1)))))))
1301 :padding 5 :expand nil))))
1302 (widget-show-all main)))
560af5c5 1303
704a1de4 1304
c775862e 1305;;; Statusbar
560af5c5 1306
c775862e 1307(define-toplevel create-statusbar (window "Statusbar")
1308 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1309 (close-button (create-button '("close" :can-default t)
1310 #'widget-destroy :object window))
1311 (counter 0))
1312
1313 (signal-connect statusbar 'text-popped
1314 #'(lambda (context-id text)
1315 (declare (ignore context-id))
1316 (format nil "Popped: ~A~%" text)))
1317
1318 (make-instance 'v-box
1319 :parent window
1320 :child (make-instance 'v-box
1321 :border-width 10 :spacing 10
1322 :child (create-button "push something"
1323 #'(lambda ()
1324 (statusbar-push statusbar 1
1325 (format nil "something ~D" (incf counter)))))
1326 :child (create-button "pop"
1327 #'(lambda ()
1328 (statusbar-pop statusbar 1)))
1329 :child (create-button "steal #4"
1330 #'(lambda ()
1331 (statusbar-remove statusbar 1 4)))
1332 :child (create-button "dump stack")
1333 :child (create-button "test contexts"))
1334 :child (list (make-instance 'h-separator) :expand nil)
1335 :child (list
1336 (make-instance 'v-box :border-width 10 :child close-button)
1337 :expand nil)
1338 :child (list statusbar :expand nil))
1339
1340 (widget-grab-focus close-button)))
560af5c5 1341
1342
1343;;; Idle test
1344
bdc1babf 1345(define-simple-dialog create-idle-test (dialog "Idle Test")
1346 (let ((label (make-instance 'label
1347 :label "count: 0" :xpad 10 :ypad 10))
1348 (idle nil)
1349 (count 0))
1350 (signal-connect dialog 'destroy
1351 #'(lambda () (when idle (idle-remove idle))))
560af5c5 1352
bdc1babf 1353 (make-instance 'v-box
f6ebddea 1354 :parent dialog :border-width 10 :spacing 10
bdc1babf 1355 :child label
1356 :child (make-instance 'frame
1357 :label "Label Container" :border-width 5
1358 :child(make-instance 'v-box
787721b6 1359 :children (make-radio-group 'radio-button
1360 '((:label "Resize-Parent" :value :parent :active t)
1361 (:label "Resize-Queue" :value :queue)
1362 (:label "Resize-Immediate" :value :immediate))
bdc1babf 1363 #'(lambda (mode)
1364 (setf
1365 (container-resize-mode (dialog-action-area dialog)) mode))))))
1366
1367 (dialog-add-button dialog "Start"
1368 #'(lambda ()
1369 (unless idle
1370 (setq idle
1371 (idle-add
1372 #'(lambda ()
1373 (incf count)
1374 (setf (label-label label) (format nil "count: ~D" count))
1375 t))))))
560af5c5 1376
bdc1babf 1377 (dialog-add-button dialog "Stop"
1378 #'(lambda ()
1379 (when idle
1380 (idle-remove idle)
1381 (setq idle nil))))))
560af5c5 1382
1383
1384
1385;;; Timeout test
1386
bdc1babf 1387(define-simple-dialog create-timeout-test (dialog "Timeout Test")
1388 (let ((label (make-instance 'label
1389 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1390 (timer nil)
1391 (count 0))
1392 (signal-connect dialog 'destroy
1393 #'(lambda () (when timer (timeout-remove timer))))
1394
1395 (dialog-add-button dialog "Start"
1396 #'(lambda ()
1397 (unless timer
1398 (setq timer
1399 (timeout-add 100
1400 #'(lambda ()
1401 (incf count)
1402 (setf (label-label label) (format nil "count: ~D" count))
1403 t))))))
1404
1405 (dialog-add-button dialog "Stop"
1406 #'(lambda ()
1407 (when timer
1408 (timeout-remove timer)
1409 (setq timer nil))))))
dddfc333 1410
1411
1412;;; Text
1413
1414(define-simple-dialog create-text (dialog "Text" :default-width 400
1415 :default-height 400)
33f468b7 1416 (let* ((text-view (make-instance 'text-view
1417 :border-width 10 :visible t :wrap-mode :word))
1418 (buffer (text-view-buffer text-view))
1419 (active-tags ()))
1420
1421 (text-buffer-create-tag buffer "Bold" :weight :bold)
1422 (text-buffer-create-tag buffer "Italic" :style :italic)
1423 (text-buffer-create-tag buffer "Underline" :underline :single)
1424
1425 (flet ((create-toggle-callback (tag-name)
1426 (let ((tag (text-tag-table-lookup
1427 (text-buffer-tag-table buffer) tag-name)))
1428 #'(lambda (active)
1429 (unless (eq (and (find tag active-tags) t) active)
1430 ;; user activated
1431 (if active
1432 (push tag active-tags)
1433 (setq active-tags (delete tag active-tags)))
842e5ffe 1434 (multiple-value-bind (non-zero-p start end)
1435 (text-buffer-get-selection-bounds buffer)
f6ebddea 1436 (declare (ignore non-zero-p))
33f468b7 1437 (if active
1438 (text-buffer-apply-tag buffer tag start end)
1439 (text-buffer-remove-tag buffer tag start end))))))))
1440
1441 (let* ((actions
1442 (make-instance 'action-group
1443 :action (create-toggle-action
1444 "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1445 (create-toggle-callback "Bold"))
1446 :action (create-toggle-action
1447 "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1448 (create-toggle-callback "Italic"))
1449 :action (create-toggle-action
1450 "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1451 (create-toggle-callback "Underline"))))
1452 (ui (make-instance 'ui-manager)))
1453
1454 (ui-manager-insert-action-group ui actions)
1455 (ui-manager-add-ui ui
1456 '((:toolbar "ToolBar"
1457 (:toolitem "Bold")
1458 (:toolitem "Italic")
1459 (:toolitem "Underline"))))
1460
1461 ;; Callback to activate/deactivate toolbar buttons when cursor
1462 ;; is moved
1463 (signal-connect buffer 'mark-set
1464 #'(lambda (location mark)
1465 (declare (ignore mark))
1466 (text-tag-table-foreach (text-buffer-tag-table buffer)
1467 #'(lambda (tag)
1468 (let ((active
1469 (or
1470 (and
1471 (text-iter-has-tag-p location tag)
1472 (not (text-iter-begins-tag-p location tag)))
1473 (text-iter-ends-tag-p location tag))))
1474 (unless (eq active (and (find tag active-tags) t))
1475 (if active
1476 (push tag active-tags)
1477 (setq active-tags (delete tag active-tags)))
1478 (setf
1479 (toggle-action-active-p
1480 (action-group-get-action actions (text-tag-name tag)))
1481 active)))))))
1482
1483 ;; Callback to apply active tags when a character is inserted
1484 (signal-connect buffer 'insert-text
1485 #'(lambda (iter &rest args)
1486 (declare (ignore args))
1487 (let ((before (text-buffer-get-iter-at-offset buffer
1488 (1- (text-iter-offset iter)))))
1489 (loop
1490 for tag in active-tags
1491 do (text-buffer-apply-tag buffer tag before iter))))
1492 :after t)
1493
1494 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1495 (container-add dialog text-view)))))
1496
560af5c5 1497
560af5c5 1498;;; Toggle buttons
1499
704a1de4 1500(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1501 (make-instance 'v-box
f6ebddea 1502 :border-width 10 :spacing 10 :parent dialog
704a1de4 1503 :children (loop
1504 for n from 1 to 3
1505 collect (make-instance 'toggle-button
1506 :label (format nil "Button~D" (1+ n))))))
560af5c5 1507
1508
1509
1510;;; Toolbar test
1511
842e5ffe 1512(defun create-toolbar (window)
787721b6 1513 (make-instance 'toolbar
842e5ffe 1514 :show-tooltips t :show-arrow nil
787721b6 1515
1516 ;; Insert a stock item
1517 :child (make-instance 'tool-button
1518 :stock "gtk-quit"
1519 :tip-text "Destroy toolbar"
1520 :tip-private "Toolbar/Quit"
1521 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1522
1523 :child (make-instance 'separator-tool-item)
1524
1525 :child (make-instance 'tool-button
1526 :label "Horizontal" :stock "gtk-go-forward"
1527 :tip-text "Horizontal toolbar layout"
1528 :tip-private "Toolbar/Horizontal"
1529 :signal (list 'clicked
1530 #'(lambda (toolbar)
1531 (setf (toolbar-orientation toolbar) :horizontal))
1532 :object :parent))
1533
1534 :child (make-instance 'tool-button
1535 :label "Vertical" :stock "gtk-go-down"
1536 :tip-text "Vertical toolbar layout"
1537 :tip-private "Toolbar/Vertical"
1538 :signal (list 'clicked
1539 #'(lambda (toolbar)
1540 (setf (toolbar-orientation toolbar) :vertical))
1541 :object :parent))
1542
1543 :child (make-instance 'separator-tool-item)
1544
1545 :children (make-radio-group 'radio-tool-button
1546 '((:label "Icons" :stock "gtk-justify-left"
1547 :tip-text "Only show toolbar icons"
1548 :tip-private "Toolbar/IconsOnly"
1549 :value :icons)
1550 (:label "Both" :stock "gtk-justify-center"
1551 :tip-text "Show toolbar icons and text"
1552 :tip-private "Toolbar/Both"
1553 :value :both :active t)
1554 (:label "Text" :stock "gtk-justify-right"
1555 :tip-text "Show toolbar text"
1556 :tip-private "Toolbar/TextOnly"
1557 :value :text))
1558 (list
1559 #'(lambda (toolbar style)
1560 (setf (toolbar-style toolbar) style))
1561 :object :parent))
1562
1563 :child (make-instance 'separator-tool-item)
1564
1565 :child (make-instance 'tool-item
1566 :child (make-instance 'entry)
1567 :tip-text "This is an unusable GtkEntry"
1568 :tip-private "Hey don't click me!")
1569
1570 :child (make-instance 'separator-tool-item)
1571
1572 :child (make-instance 'tool-button
1573 :label "Enable" :stock "gtk-add"
1574 :tip-text "Enable tooltips"
1575 :tip-private "Toolbar/EnableTooltips"
1576 :signal (list 'clicked
1577 #'(lambda (toolbar)
1578 (setf (toolbar-show-tooltips-p toolbar) t))
1579 :object :parent))
1580
1581 :child (make-instance 'tool-button
1582 :label "Disable" :stock "gtk-remove"
1583 :tip-text "Disable tooltips"
1584 :tip-private "Toolbar/DisableTooltips"
1585 :signal (list 'clicked
1586 #'(lambda (toolbar)
1587 (setf (toolbar-show-tooltips-p toolbar) nil))
1588 :object :parent))
1589
1590;; :child (make-instance 'separator-tool-item)
1591
1592;; :child (make-instance 'tool-button
1593;; :label "GTK" :icon #p"clg:examples;gtk.png"
1594;; :tip-text "GTK+ Logo"
1595;; :tip-private "Toolbar/GTK+")
1596 ))
560af5c5 1597
842e5ffe 1598(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1599 (container-add window (create-toolbar window)))
1600
560af5c5 1601
1602
1603;;; Tooltips test
1604
bdc1babf 1605(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1606 (let ((tooltips (make-instance 'tooltips)))
1607 (flet ((create-button (label tip-text tip-private)
1608 (let ((button (make-instance 'toggle-button :label label)))
1609 (tooltips-set-tip tooltips button tip-text tip-private)
1610 button)))
1611 (make-instance 'v-box
f6ebddea 1612 :parent dialog :border-width 10 :spacing 10
bdc1babf 1613 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
812dd869 1614 :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 1615
1616
1617;;; UI Manager
1618
1619(defvar *ui-description*
1620 '((:menubar "MenuBar"
1621 (:menu "FileMenu"
1622 (:menuitem "New")
1623 (:menuitem "Open")
1624 (:menuitem "Save")
1625 (:menuitem "SaveAs")
1626 :separator
1627 (:menuitem "Quit"))
1628 (:menu "PreferencesMenu"
1629 (:menu "ColorMenu"
1630 (:menuitem "Red")
1631 (:menuitem "Green")
1632 (:menuitem "Blue"))
1633 (:menu "ShapeMenu"
1634 (:menuitem "Square")
1635 (:menuitem "Rectangle")
1636 (:menuitem "Oval"))
1637 (:menuitem "Bold"))
1638 (:menu "HelpMenu"
1639 (:menuitem "About")))
1640 (:toolbar "ToolBar"
1641 (:toolitem "Open")
1642 (:toolitem "Quit")
1643 (:separator "Sep1")
1644 (:toolitem "Logo"))))
1645
33f468b7 1646(define-toplevel create-ui-manager (window "UI Manager")
dddfc333 1647 (let ((actions
1648 (make-instance 'action-group
1649 :name "Actions"
1650 :action (create-action "FileMenu" nil "_File")
1651 :action (create-action "PreferencesMenu" nil "_Preferences")
1652 :action (create-action "ColorMenu" nil "_Color")
1653 :action (create-action "ShapeMenu" nil "_Shape")
1654 :action (create-action "HelpMenu" nil "_Help")
1655 :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
33f468b7 1656 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
dddfc333 1657 :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1658 :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
33f468b7 1659 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
dddfc333 1660 :action (create-action "About" nil "_About" "<control>A" "About")
1661 :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1662 :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1663 :actions (create-radio-actions
1664 '(("Red" nil "_Red" "<control>R" "Blood")
1665 ("Green" nil "_Green" "<control>G" "Grass")
1666 ("Blue" nil "_Blue" "<control>B" "Sky"))
1667 "Green")
1668 :actions (create-radio-actions
1669 '(("Square" nil "_Square" "<control>S" "Square")
1670 ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1671 ("Oval" nil "_Oval" "<control>O" "Egg")))))
1672 (ui (make-instance 'ui-manager)))
1673
1674 (ui-manager-insert-action-group ui actions)
1675 (ui-manager-add-ui ui *ui-description*)
1676
33f468b7 1677 (window-add-accel-group window (ui-manager-accel-group ui))
dddfc333 1678
1679 (make-instance 'v-box
f6ebddea 1680 :parent window
dddfc333 1681 :child (list
1682 (ui-manager-get-widget ui "/MenuBar")
1683 :expand nil :fill nil)
1684 :child (list
1685 (ui-manager-get-widget ui "/ToolBar")
1686 :expand nil :fill nil)
1687 :child (make-instance 'label
1688 :label "Type <alt> to start"
1689 :xalign 0.5 :yalign 0.5
1690 :width-request 200 :height-request 200))))
560af5c5 1691
1692
1693
560af5c5 1694;;; Main window
1695
1696(defun create-main-window ()
704a1de4 1697;; (rc-parse "clg:examples;testgtkrc2")
1698;; (rc-parse "clg:examples;testgtkrc")
196fe1e9 1699
1700 (let* ((button-specs
560af5c5 1701 '(("button box" create-button-box)
704a1de4 1702 ("buttons" create-buttons)
1703 ("calendar" create-calendar)
1704 ("check buttons" create-check-buttons)
704a1de4 1705 ("color selection" create-color-selection)
aa9ceddc 1706 ("cursors" create-cursors)
704a1de4 1707 ("dialog" create-dialog)
1708;; ; ("dnd")
1709 ("entry" create-entry)
1710;; ("event watcher")
96b68e83 1711 ("enxpander" create-expander)
704a1de4 1712 ("file chooser" create-file-chooser)
1713;; ("font selection")
842e5ffe 1714 ("handle box" create-handle-box)
704a1de4 1715 ("image" create-image)
704a1de4 1716 ("labels" create-labels)
1717 ("layout" create-layout)
21f6214a 1718 ("list" create-list)
560af5c5 1719 ("menus" create-menus)
704a1de4 1720;; ("modal window")
1721 ("notebook" create-notebook)
1722 ("panes" create-panes)
977a550d 1723 ("progress bar" create-progress-bar)
704a1de4 1724 ("radio buttons" create-radio-buttons)
1725 ("range controls" create-range-controls)
1726;; ("rc file")
1727 ("reparent" create-reparent)
1728 ("rulers" create-rulers)
1729;; ("saved position")
1730 ("scrolled windows" create-scrolled-windows)
33f468b7 1731 ("size group" create-size-group)
704a1de4 1732;; ("shapes" create-shapes)
1733 ("spinbutton" create-spins)
c775862e 1734 ("statusbar" create-statusbar)
bdc1babf 1735 ("test idle" create-idle-test)
704a1de4 1736;; ("test mainloop")
1737;; ("test scrolling")
1738;; ("test selection")
bdc1babf 1739 ("test timeout" create-timeout-test)
dddfc333 1740 ("text" create-text)
704a1de4 1741 ("toggle buttons" create-toggle-buttons)
842e5ffe 1742 ("toolbar" create-toolbar-window)
bdc1babf 1743 ("tooltips" create-tooltips)
704a1de4 1744;; ("tree" #|create-tree|#)
dddfc333 1745 ("UI manager" create-ui-manager)
704a1de4 1746))
1747 (main-window (make-instance 'window
1748 :title "testgtk.lisp" :name "main_window"
1749 :default-width 200 :default-height 400
1750 :allow-grow t :allow-shrink nil))
1751 (scrolled-window (make-instance 'scrolled-window
1752 :hscrollbar-policy :automatic
1753 :vscrollbar-policy :automatic
1754 :border-width 10))
1755 (close-button (make-instance 'button
1756 :label "close" :can-default t
1757 :signal (list 'clicked #'widget-destroy
1758 :object main-window))))
560af5c5 1759
977a550d 1760 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1761 (setf
1762 (window-icon main-window)
1763 (gdk:pixbuf-add-alpha icon t 254 254 252)))
812dd869 1764
560af5c5 1765 ;; Main box
704a1de4 1766 (make-instance 'v-box
560af5c5 1767 :parent main-window
704a1de4 1768 :child-args '(:expand nil)
1769 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1770 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
1771 :child (list scrolled-window :expand t)
1772 :child (make-instance 'h-separator)
1773 :child (make-instance 'v-box
1774 :homogeneous nil :spacing 10 :border-width 10
1775 :child close-button))
1776
1777 (let ((content-box
1778 (make-instance 'v-box
1779 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1780 :children (mapcar #'(lambda (spec)
1781 (apply #'create-button spec))
1782 button-specs))))
1783 (scrolled-window-add-with-viewport scrolled-window content-box))
560af5c5 1784
704a1de4 1785 (widget-grab-focus close-button)
560af5c5 1786 (widget-show-all main-window)
1787 main-window))
1788
704a1de4 1789(clg-init)
1790(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).