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