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