~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
A couple of smaller changes.
[clg] / examples / testgtk.lisp
CommitLineData
0d07716f 1;; Common Lisp bindings for GTK+ v2.0
8179fd68 2;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
0d07716f 3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
c1f1a833 18;; $Id: testgtk.lisp,v 1.24 2005/03/06 17:12:22 espen Exp $
0d07716f 19
35ec512c 20
21;(use-package "GTK")
22(in-package "GTK")
23
24(defmacro define-toplevel (name (window title &rest initargs) &body body)
25 `(let ((,window nil))
0d07716f 26 (defun ,name ()
35ec512c 27 (unless ,window
6490e9f1 28 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
35ec512c 29 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
0d07716f 30 ,@body)
31
35ec512c 32 (if (not (widget-visible-p ,window))
6490e9f1 33 (widget-show ,window)
35ec512c 34 (widget-hide ,window)))))
35
0d07716f 36
35ec512c 37(defmacro define-dialog (name (dialog title &optional (class 'dialog)
38 &rest initargs)
39 &body body)
40 `(let ((,dialog nil))
0d07716f 41 (defun ,name ()
35ec512c 42 (unless ,dialog
6490e9f1 43 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
35ec512c 44 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
45 ,@body)
0d07716f 46
35ec512c 47 (if (not (widget-visible-p ,dialog))
48 (widget-show ,dialog)
49 (widget-hide ,dialog)))))
0d07716f 50
51
35ec512c 52(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
53 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
e025589b 54 ,@body
55 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
0d07716f 56
57
0d07716f 58
59;;; Pixmaps used in some of the tests
60
61(defvar gtk-mini-xpm
4fb50b71 62 #("15 20 17 1"
0d07716f 63 " c None"
64 ". c #14121F"
65 "+ c #278828"
66 "@ c #9B3334"
67 "# c #284C72"
68 "$ c #24692A"
69 "% c #69282E"
70 "& c #37C539"
71 "* c #1D2F4D"
72 "= c #6D7076"
73 "- c #7D8482"
74 "; c #E24A49"
75 "> c #515357"
76 ", c #9B9C9B"
77 "' c #2FA232"
78 ") c #3CE23D"
79 "! c #3B6CCB"
80 " "
81 " ***> "
82 " >.*!!!* "
83 " ***....#*= "
84 " *!*.!!!**!!# "
85 " .!!#*!#*!!!!# "
86 " @%#!.##.*!!$& "
87 " @;%*!*.#!#')) "
88 " @;;@%!!*$&)'' "
89 " @%.%@%$'&)$+' "
90 " @;...@$'*'*)+ "
91 " @;%..@$+*.')$ "
92 " @;%%;;$+..$)# "
93 " @;%%;@$$$'.$# "
94 " %;@@;;$$+))&* "
95 " %;;;@+$&)&* "
96 " %;;@'))+> "
97 " %;@'&# "
98 " >%$$ "
99 " >= "))
100
101(defvar book-closed-xpm
4fb50b71 102 #("16 16 6 1"
0d07716f 103 " c None s None"
104 ". c black"
105 "X c red"
106 "o c yellow"
107 "O c #808080"
108 "# c white"
109 " "
110 " .. "
111 " ..XX. "
112 " ..XXXXX. "
113 " ..XXXXXXXX. "
114 ".ooXXXXXXXXX. "
115 "..ooXXXXXXXXX. "
116 ".X.ooXXXXXXXXX. "
117 ".XX.ooXXXXXX.. "
118 " .XX.ooXXX..#O "
119 " .XX.oo..##OO. "
120 " .XX..##OO.. "
121 " .X.#OO.. "
122 " ..O.. "
123 " .. "
124 " "))
125
126(defvar mini-page-xpm
4fb50b71 127 #("16 16 4 1"
0d07716f 128 " c None s None"
129 ". c black"
130 "X c white"
131 "o c #808080"
132 " "
133 " ....... "
134 " .XXXXX.. "
135 " .XoooX.X. "
136 " .XXXXX.... "
137 " .XooooXoo.o "
138 " .XXXXXXXX.o "
139 " .XooooooX.o "
140 " .XXXXXXXX.o "
141 " .XooooooX.o "
142 " .XXXXXXXX.o "
143 " .XooooooX.o "
144 " .XXXXXXXX.o "
145 " ..........o "
146 " oooooooooo "
147 " "))
148
149(defvar book-open-xpm
4fb50b71 150 #("16 16 4 1"
0d07716f 151 " c None s None"
152 ". c black"
153 "X c #808080"
154 "o c white"
155 " "
156 " .. "
157 " .Xo. ... "
158 " .Xoo. ..oo. "
159 " .Xooo.Xooo... "
160 " .Xooo.oooo.X. "
161 " .Xooo.Xooo.X. "
162 " .Xooo.oooo.X. "
163 " .Xooo.Xooo.X. "
164 " .Xooo.oooo.X. "
165 " .Xoo.Xoo..X. "
166 " .Xo.o..ooX. "
167 " .X..XXXXX. "
168 " ..X....... "
169 " .. "
170 " "))
171
172
173
174;;; Button box
175
4fb50b71 176(defun create-bbox-in-frame (class frame-label spacing width height layout)
35ec512c 177 (declare (ignore width height))
178 (make-instance 'frame
179 :label frame-label
180 :child (make-instance class
181 :border-width 5 :layout-style layout :spacing spacing
8804934b 182 :child (make-instance 'button :stock "gtk-ok")
183 :child (make-instance 'button :stock "gtk-cancel")
184 :child (make-instance 'button :stock "gtk-help"))))
35ec512c 185
186(define-toplevel create-button-box (window "Button Boxes")
187 (make-instance 'v-box
6490e9f1 188 :parent window :border-width 10 :spacing 10
35ec512c 189 :child (make-instance 'frame
190 :label "Horizontal Button Boxes"
191 :child (make-instance 'v-box
192 :border-width 10 :spacing 10
193 :children (mapcar
194 #'(lambda (args)
195 (apply #'create-bbox-in-frame
196 'h-button-box args))
197 '(("Spread" 40 85 20 :spread)
198 ("Edge" 40 85 20 :edge)
199 ("Start" 40 85 20 :start)
200 ("End" 40 85 20 :end)))))
201 :child (make-instance 'frame
202 :label "Vertical Button Boxes"
203 :child (make-instance 'h-box
204 :border-width 10 :spacing 10
205 :children (mapcar
206 #'(lambda (args)
207 (apply #'create-bbox-in-frame
208 'v-button-box args))
209 '(("Spread" 30 85 20 :spread)
210 ("Edge" 30 85 20 :edge)
211 ("Start" 30 85 20 :start)
212 ("End" 30 85 20 :end)))))))
4fb50b71 213
214
215;; Buttons
216
35ec512c 217(define-simple-dialog create-buttons (dialog "Buttons")
4fb50b71 218 (let ((table (make-instance 'table
35ec512c 219 :n-rows 3 :n-columns 3 :homogeneous nil
4fb50b71 220 :row-spacing 5 :column-spacing 5 :border-width 10
35ec512c 221 :parent dialog))
222 (buttons (loop
223 for n from 1 to 10
224 collect (make-instance 'button
225 :label (format nil "button~D" (1+ n))))))
226
4fb50b71 227 (dotimes (column 3)
228 (dotimes (row 3)
35ec512c 229 (let ((button (nth (+ (* 3 row) column) buttons))
230 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
4fb50b71 231 (signal-connect button 'clicked
232 #'(lambda ()
233 (if (widget-visible-p button+1)
234 (widget-hide button+1)
235 (widget-show button+1))))
81f2aa93 236 (table-attach table button column (1+ column) row (1+ row)
6490e9f1 237 :options '(:expand :fill)))))))
0d07716f 238
239
240;; Calenadar
241
35ec512c 242(define-simple-dialog create-calendar (dialog "Calendar")
243 (make-instance 'v-box
6490e9f1 244 :parent dialog :border-width 10
35ec512c 245 :child (make-instance 'calendar)))
0d07716f 246
247
248;;; Check buttons
249
35ec512c 250(define-simple-dialog create-check-buttons (dialog "Check Buttons")
251 (make-instance 'v-box
6490e9f1 252 :border-width 10 :spacing 10 :parent dialog
35ec512c 253 :children (loop
254 for n from 1 to 3
255 collect (make-instance 'check-button
256 :label (format nil "Button~D" n)))))
0d07716f 257
258
259
260;;; Color selection
261
35ec512c 262(define-dialog create-color-selection (dialog "Color selection dialog"
263 'color-selection-dialog
6490e9f1 264 :allow-grow nil :allow-shrink nil
265 :show-children nil)
266 (with-slots (colorsel) dialog
267 (let ((button (make-instance 'check-button :label "Show Opacity")))
268 (dialog-add-action-widget dialog button
269 #'(lambda ()
270 (setf
271 (color-selection-has-opacity-control-p colorsel)
272 (toggle-button-active-p button)))))
273
274 (let ((button (make-instance 'check-button :label "Show Palette")))
275 (dialog-add-action-widget dialog button
276 #'(lambda ()
277 (setf
278 (color-selection-has-palette-p colorsel)
279 (toggle-button-active-p button)))))
35ec512c 280
281 (signal-connect dialog :ok
282 #'(lambda ()
283 (let ((color (color-selection-current-color colorsel)))
284 (format t "Selected color: ~A~%" color)
285 (setf (color-selection-current-color colorsel) color)
286 (widget-hide dialog))))
0d07716f 287
35ec512c 288 (signal-connect dialog :cancel #'widget-destroy :object t)))
0d07716f 289
0d07716f 290
291;;; Cursors
292
293(defun clamp (n min-val max-val)
294 (declare (number n min-val max-val))
295 (max (min n max-val) min-val))
296
af5eb952 297(defun set-cursor (spinner drawing-area label)
298 (let ((cursor
299 (glib:int-enum
300 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
301 'gdk:cursor-type)))
302 (setf (label-label label) (string-downcase cursor))
303 (setf (widget-cursor drawing-area) cursor)))
304
305(defun cursor-expose (drawing-area event)
306 (declare (ignore event))
307 (multiple-value-bind (width height)
8804934b 308 (widget-get-size-allocation drawing-area)
af5eb952 309 (let* ((window (widget-window drawing-area))
310 (style (widget-style drawing-area))
311 (white-gc (style-white-gc style))
312 (gray-gc (style-bg-gc style :normal))
313 (black-gc (style-black-gc style)))
314 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
315 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
316 (floor height 2))
317 (gdk:draw-rectangle window gray-gc t (floor width 3)
318 (floor height 3) (floor width 3)
319 (floor height 3))))
320 t)
321
322(define-simple-dialog create-cursors (dialog "Cursors")
323 (let ((spinner (make-instance 'spin-button
324 :adjustment (adjustment-new
325 0 0
326 (1- (enum-int :last-cursor 'gdk:cursor-type))
327 2 10 0)))
328 (drawing-area (make-instance 'drawing-area
329 :width-request 80 :height-request 80
8f0159a6 330 :events '(:exposure :button-press)))
af5eb952 331 (label (make-instance 'label :label "XXX")))
332
333 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
334
335 (signal-connect drawing-area 'button-press-event
336 #'(lambda (event)
337 (case (gdk:event-button event)
45314d76 338 (1 (spin-button-spin spinner :step-forward))
339 (3 (spin-button-spin spinner :step-backward)))
af5eb952 340 t))
0d07716f 341
af5eb952 342 (signal-connect drawing-area 'scroll-event
343 #'(lambda (event)
344 (case (gdk:event-direction event)
45314d76 345 (:up (spin-button-spin spinner :step-forward))
346 (:down (spin-button-spin spinner :step-backward)))
af5eb952 347 t))
0d07716f 348
af5eb952 349 (signal-connect spinner 'changed
350 #'(lambda ()
351 (set-cursor spinner drawing-area label)))
0d07716f 352
af5eb952 353 (make-instance 'v-box
6490e9f1 354 :parent dialog :border-width 10 :spacing 5
af5eb952 355 :child (list
356 (make-instance 'h-box
357 :border-width 5
358 :child (list
359 (make-instance 'label :label "Cursor Value : ")
360 :expand nil)
361 :child spinner)
362 :expand nil)
363 :child (make-instance 'frame
af5eb952 364 :label "Cursor Area" :label-xalign 0.5 :border-width 10
365 :child drawing-area)
366 :child (list label :expand nil))
367
368 (widget-realize drawing-area)
369 (set-cursor spinner drawing-area label)))
0d07716f 370
371
372;;; Dialog
373
35ec512c 374(let ((dialog nil))
375 (defun create-dialog ()
376 (unless dialog
377 (setq dialog (make-instance 'dialog
378 :title "Dialog" :default-width 200
379 :button "Toggle"
380 :button (list "gtk-ok" #'widget-destroy :object t)
381 :signal (list 'destroy
382 #'(lambda ()
383 (setq dialog nil)))))
384
385 (let ((label (make-instance 'label
386 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
387 :parent dialog)))
388 (signal-connect dialog "Toggle"
389 #'(lambda ()
390 (if (widget-visible-p label)
391 (widget-hide label)
392 (widget-show label))))))
0d07716f 393
35ec512c 394 (if (widget-visible-p dialog)
395 (widget-hide dialog)
396 (widget-show dialog))))
0d07716f 397
398
399;; Entry
400
35ec512c 401(define-simple-dialog create-entry (dialog "Entry")
402 (let ((main (make-instance 'v-box
403 :border-width 10 :spacing 10 :parent dialog)))
4fb50b71 404
35ec512c 405 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
406 (editable-select-region entry 0 5) ; this has no effect when
407 ; entry is editable
408;; (editable-insert-text entry "great " 6)
409;; (editable-delete-text entry 6 12)
4fb50b71 410
e52cf822 411 (let ((combo (make-instance 'combo-box-entry
35ec512c 412 :parent main
e52cf822 413 :content '("item0"
414 "item1 item1"
415 "item2 item2 item2"
416 "item3 item3 item3 item3"
417 "item4 item4 item4 item4 item4"
418 "item5 item5 item5 item5 item5 item5"
419 "item6 item6 item6 item6 item6"
420 "item7 item7 item7 item7"
421 "item8 item8 item8"
422 "item9 item9"))))
423 (with-slots (child) combo
424 (setf (editable-text child) "hello world")
425 (editable-select-region child 0)))
35ec512c 426
427 (flet ((create-check-button (label slot)
428 (make-instance 'check-button
429 :label label :active t :parent main
430 :signal (list 'toggled
431 #'(lambda (button)
432 (setf (slot-value entry slot)
433 (toggle-button-active-p button)))
434 :object t))))
435
436 (create-check-button "Editable" 'editable)
437 (create-check-button "Visible" 'visibility)
6490e9f1 438 (create-check-button "Sensitive" 'sensitive)))))
0d07716f 439
0d07716f 440
36c95ad8 441;; Expander
442
443(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
444 (make-instance 'v-box
6490e9f1 445 :parent dialog :spacing 5 :border-width 5
36c95ad8 446 :child (create-label "Expander demo. Click on the triangle for details.")
447 :child (make-instance 'expander
448 :label "Details"
449 :child (create-label "Details can be shown or hidden."))))
450
0d07716f 451
35ec512c 452;; File chooser dialog
0d07716f 453
35ec512c 454(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
d5e2ce7c 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
35ec512c 461 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
462 (dialog-add-button dialog "gtk-ok"
463 #'(lambda ()
ab652f5f 464 (if (slot-boundp dialog 'filename)
7c1f9a1e 465 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
466 (write-line "No files selected"))
35ec512c 467 (widget-destroy dialog))))
0d07716f 468
469
b9d3ad20 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
0d07716f 479
480;;; Handle box
481
ab652f5f 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")))
35ec512c 501
502;;; Image
0d07716f 503
c1f1a833 504(define-toplevel create-image (window "Image" :resizable nil)
35ec512c 505 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
0d07716f 506
507
508;;; Labels
509
35ec512c 510(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
4fb50b71 511 (flet ((create-label-in-frame (frame-label label-text &rest args)
512 (list
513 (make-instance 'frame
514 :label frame-label
35ec512c 515 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
4fb50b71 516 :fill nil :expand nil)))
35ec512c 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"
0d07716f 524"This is a Multi-line label.
525Second line
4fb50b71 526Third line")
35ec512c 527 :child (create-label-in-frame "Left Justified Label"
0d07716f 528"This is a Left-Justified
529Multi-line.
4fb50b71 530Third line"
35ec512c 531 :justify :left)
532 :child (create-label-in-frame "Right Justified Label"
0d07716f 533"This is a Right-Justified
534Multi-line.
4fb50b71 535Third line"
35ec512c 536 :justify :right))
537 :child (make-instance 'v-box
538 :spacing 5
539 :child (create-label-in-frame "Line wrapped label"
0d07716f 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.
4fb50b71 541 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
35ec512c 542 :wrap t)
543
544 :child (create-label-in-frame "Filled, wrapped label"
0d07716f 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.
4fb50b71 547 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
35ec512c 548 :justify :fill :wrap t)
549
550 :child (create-label-in-frame "Underlined label"
0d07716f 551"This label is underlined!
4fb50b71 552This one is underlined (こんにちは) in quite a funky fashion"
35ec512c 553 :justify :left
554 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
0d07716f 555
556
557;;; Layout
558
af5eb952 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)
35ec512c 578
579(define-toplevel create-layout (window "Layout" :default-width 200
580 :default-height 200)
4fb50b71 581 (let ((layout (make-instance 'layout
582 :parent (make-instance 'scrolled-window :parent window)
8f0159a6 583 :width 1600 :height 128000 :events '(:exposure)
6490e9f1 584 :signal (list 'expose-event #'layout-expose :object t))))
4fb50b71 585
586 (with-slots (hadjustment vadjustment) layout
587 (setf
588 (adjustment-step-increment hadjustment) 10.0
589 (adjustment-step-increment vadjustment) 10.0))
0d07716f 590
591 (dotimes (i 16)
592 (dotimes (j 16)
35ec512c 593 (let ((text (format nil "Button ~D, ~D" i j)))
6490e9f1 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)))))
0d07716f 600
35ec512c 601 (loop
602 for i from 16 below 1280
603 do (let ((text (format nil "Button ~D, ~D" i 0)))
6490e9f1 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))))))
4fb50b71 610
0d07716f 611
612
613;;; List
614
549265c1 615(define-simple-dialog create-list (dialog "List" :default-height 400)
744118a7 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)))
0d07716f 622
549265c1 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))
744118a7 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
6490e9f1 647 :parent dialog :border-width 10 :spacing 10
744118a7 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))))
0d07716f 704
705
706;; Menus
707
708(defun create-menu (depth tearoff)
709 (unless (zerop depth)
35ec512c 710 (let ((menu (make-instance 'menu)))
0d07716f 711 (when tearoff
35ec512c 712 (let ((menu-item (make-instance 'tearoff-menu-item)))
713 (menu-shell-append menu menu-item)))
0d07716f 714 (let ((group nil))
715 (dotimes (i 5)
35ec512c 716 (let ((menu-item
717 (make-instance 'radio-menu-item
718 :label (format nil "item ~2D - ~D" depth (1+ i)))))
719 (if group
ab652f5f 720 (add-to-radio-group menu-item group)
35ec512c 721 (setq group menu-item))
0d07716f 722 (unless (zerop (mod depth 2))
35ec512c 723 (setf (check-menu-item-active-p menu-item) t))
724 (menu-shell-append menu menu-item)
0d07716f 725 (when (= i 3)
35ec512c 726 (setf (widget-sensitive-p menu-item) nil))
8804934b 727 (let ((submenu (create-menu (1- depth) t)))
728 (when submenu
729 (setf (menu-item-submenu menu-item) submenu))))))
4fb50b71 730 menu)))
0d07716f 731
732
35ec512c 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))))
ab652f5f 737; (window-add-accel-group dialog accel-group)
35ec512c 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
e52cf822 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))))
0d07716f 760
e52cf822 761 (widget-show-all main)))
0d07716f 762
763
764;;; Notebook
765
8804934b 766(defun create-notebook-page (notebook page-num book-closed)
35ec512c 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
6490e9f1 806 :show-children t
35ec512c 807 :child-args '(:expand nil)
8804934b 808 :child (make-instance 'image :pixbuf book-closed)
35ec512c 809 :child (make-instance 'label :label title)))
810 (menu-box (make-instance 'h-box
6490e9f1 811 :show-children t
35ec512c 812 :child-args '(:expand nil)
8804934b 813 :child (make-instance 'image :pixbuf book-closed)
35ec512c 814 :child (make-instance 'label :label title))))
815
816 (widget-show-all page)
817 (notebook-append notebook page label-box menu-box))))
0d07716f 818
0d07716f 819
35ec512c 820(define-simple-dialog create-notebook (dialog "Notebook")
821 (let ((main (make-instance 'v-box :parent dialog)))
8804934b 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
35ec512c 825 :border-width 10 :tab-pos :top :parent main)))
8804934b 826 (flet ((set-image (page func pixbuf)
827 (setf
828 (image-pixbuf
829 (first (container-children (funcall func notebook page))))
830 pixbuf)))
35ec512c 831 (signal-connect notebook 'switch-page
832 #'(lambda (pointer page)
833 (declare (ignore pointer))
ab652f5f 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)
35ec512c 837 (let ((curpage (notebook-current-page notebook)))
ab652f5f 838 (set-image curpage #'notebook-menu-label book-closed)
839 (set-image curpage #'notebook-tab-label book-closed))))))
8804934b 840 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
35ec512c 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))
e52cf822 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
8804934b 896 do (create-notebook-page notebook i book-closed))))))
e52cf822 897 :object t)))
35ec512c 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)))
0d07716f 923
924
925;;; Panes
926
927(defun toggle-resize (child)
7c1f9a1e 928 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
0d07716f 929
930(defun toggle-shrink (child)
7c1f9a1e 931 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
0d07716f 932
933(defun create-pane-options (paned frame-label label1 label2)
7c1f9a1e 934 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
81f2aa93 935 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
35ec512c 936 (let ((check-button (make-instance 'check-button :label "Resize")))
81f2aa93 937 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 941 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
7c1f9a1e 942 (signal-connect check-button 'toggled
943 #'toggle-shrink :object (paned-child1 paned)))
0d07716f 944
81f2aa93 945 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
7c1f9a1e 946 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
81f2aa93 947 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 951 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
7c1f9a1e 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)))
0d07716f 955
35ec512c 956(define-toplevel create-panes (window "Panes")
957 (let* ((hpaned (make-instance 'h-paned
4fb50b71 958 :child1 (make-instance 'frame
35ec512c 959 :width-request 60 :height-request 60
960 :shadow-type :in
7c1f9a1e 961 :child (make-instance 'button :label "Hi there"))
35ec512c 962 :child2 (make-instance 'frame
963 :width-request 80 :height-request 60
964 :shadow-type :in)))
965 (vpaned (make-instance 'v-paned
4fb50b71 966 :border-width 5
967 :child1 hpaned
968 :child2 (make-instance 'frame
35ec512c 969 :width-request 80 :height-request 60
970 :shadow-type :in))))
4fb50b71 971
35ec512c 972 (make-instance 'v-box
4fb50b71 973 :parent window
35ec512c 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"))))
0d07716f 978
979
0d07716f 980;;; Progress bar
981
8804934b 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
6490e9f1 999 :parent dialog :border-width 10 :spacing 10
8804934b 1000 :child progress
1001 :child activity-mode-button)
1002
1003 (signal-connect dialog 'destroy
1004 #'(lambda () (when timer (timeout-remove timer))))))
0d07716f 1005
1006
1007;;; Radio buttons
1008
35ec512c 1009(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1010 (make-instance 'v-box
6490e9f1 1011 :parent dialog :border-width 10 :spacing 10
8179fd68 1012 :children (make-radio-group 'radio-button
1013 '((:label "button1") (:label "button2") (:label "button3"))
1014 nil)))
0d07716f 1015
1016
1017;;; Rangle controls
1018
35ec512c 1019(define-simple-dialog create-range-controls (dialog "Range controls")
0d07716f 1020 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
35ec512c 1021 (make-instance 'v-box
6490e9f1 1022 :parent dialog :border-width 10 :spacing 10
35ec512c 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))))
0d07716f 1028
1029
1030;;; Reparent test
1031
35ec512c 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))
8804934b 1035 (label (make-instance 'label :label "Hello World")))
0d07716f 1036
35ec512c 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)))
0d07716f 1047
35ec512c 1048 (box-pack-start (create-frame "Frame 1") label nil t 0)
1049 (create-frame "Frame 2"))
1050 (widget-show-all main)))
0d07716f 1051
1052
1053;;; Rulers
1054
35ec512c 1055(define-toplevel create-rulers (window "Rulers"
1056 :default-width 300 :default-height 300
8f0159a6 1057 :events '(:pointer-motion :pointer-motion-hint))
81f2aa93 1058 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1059 (h-ruler (make-instance 'h-ruler
35ec512c 1060 :metric :centimeters :lower 100.0d0 :upper 0.0d0
81f2aa93 1061 :position 0.0d0 :max-size 20.0d0))
1062 (v-ruler (make-instance 'v-ruler
35ec512c 1063 :lower 5.0d0 :upper 15.0d0
1064 :position 0.0d0 :max-size 20.0d0)))
81f2aa93 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)))
0d07716f 1071
1072
1073;;; Scrolled window
1074
35ec512c 1075(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1076 :default-width 300
1077 :default-height 300)
4fb50b71 1078 (let* ((scrolled-window
1079 (make-instance 'scrolled-window
35ec512c 1080 :parent dialog :border-width 10
1081 :vscrollbar-policy :automatic
4fb50b71 1082 :hscrollbar-policy :automatic))
1083 (table
1084 (make-instance 'table
35ec512c 1085 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
4fb50b71 1086 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1087 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
0d07716f 1088
0d07716f 1089 (scrolled-window-add-with-viewport scrolled-window table)
0d07716f 1090 (dotimes (i 20)
1091 (dotimes (j 20)
1092 (let ((button
35ec512c 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)))
0d07716f 1097
1098
81f2aa93 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
6490e9f1 1120 :parent dialog :border-width 5 :spacing 5
81f2aa93 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
0d07716f 1135;;; Shapes
1136
83bab9b6 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))))
4fb50b71 1143
83bab9b6 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))
4fb50b71 1149
83bab9b6 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)))
0d07716f 1167
83bab9b6 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))))))
0d07716f 1175
83bab9b6 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)))))
0d07716f 1209
1210
1211
1212;;; Spin buttons
1213
35ec512c 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))))
c1f1a833 1226 (multiple-value-bind (sec min hour date month year day daylight-p zone)
1227 (get-decoded-time)
1228 (declare (ignore sec min hour day daylight-p zone))
1229 (make-instance 'frame
1230 :label "Not accelerated" :parent main
1231 :child (make-instance 'h-box
1232 :border-width 10
1233 :child-args '(:padding 5)
1234 :child (create-date-spinner "Day : "
1235 (adjustment-new date 1 31 1 5 0) :out)
1236 :child (create-date-spinner "Month : "
1237 (adjustment-new month 1 12 1 5 0) :etched-in)
1238 :child (create-date-spinner "Year : "
1239 (adjustment-new year 0 2100 1 100 0) :in)))))
35ec512c 1240
1241 (let ((spinner1 (make-instance 'spin-button
1242 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1243 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1244 (spinner2 (make-instance 'spin-button
1245 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1246 :climb-rate 1.0 :wrap t))
1247 (value-label (make-instance 'label :label "0")))
1248 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1249 #'(lambda ()
1250 (setf
1251 (spin-button-digits spinner1)
1252 (floor (spin-button-value spinner2)))))
1253
1254 (make-instance 'frame
1255 :label "Accelerated" :parent main
1256 :child (make-instance 'v-box
1257 :border-width 5
1258 :child (list
1259 (make-instance 'h-box
1260 :child-args '(:padding 5)
1261 :child (make-instance 'v-box
1262 :child (make-instance 'label
1263 :label "Value :"
1264 :xalign 0.0 :yalign 0.5)
1265 :child spinner1)
1266 :child (make-instance 'v-box
1267 :child (make-instance 'label
1268 :label "Digits :"
1269 :xalign 0.0 :yalign 0.5)
1270 :child spinner2))
1271 :expand nil :padding 5)
1272 :child (make-instance 'check-button
1273 :label "Snap to 0.5-ticks" :active t
1274 :signal (list 'clicked
1275 #'(lambda (button)
1276 (setf
1277 (spin-button-snap-to-ticks-p spinner1)
1278 (toggle-button-active-p button)))
1279 :object t))
1280 :child (make-instance 'check-button
1281 :label "Numeric only input mode" :active t
1282 :signal (list 'clicked
1283 #'(lambda (button)
1284 (setf
1285 (spin-button-numeric-p spinner1)
1286 (toggle-button-active-p button)))
1287 :object t))
1288 :child value-label
1289 :child (list
1290 (make-instance 'h-box
1291 :child-args '(:padding 5)
1292 :child (make-instance 'button
1293 :label "Value as Int"
1294 :signal (list 'clicked
1295 #'(lambda ()
1296 (setf
1297 (label-label value-label)
1298 (format nil "~D"
1299 (spin-button-value-as-int
1300 spinner1))))))
1301 :child (make-instance 'button
1302 :label "Value as Float"
1303 :signal (list 'clicked
1304 #'(lambda ()
1305 (setf
1306 (label-label value-label)
1307 (format nil
1308 (format nil "~~,~DF"
1309 (spin-button-digits spinner1))
1310 (spin-button-value spinner1)))))))
1311 :padding 5 :expand nil))))
1312 (widget-show-all main)))
0d07716f 1313
35ec512c 1314
5ff67599 1315;;; Statusbar
0d07716f 1316
5ff67599 1317(define-toplevel create-statusbar (window "Statusbar")
1318 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1319 (close-button (create-button '("close" :can-default t)
1320 #'widget-destroy :object window))
1321 (counter 0))
1322
1323 (signal-connect statusbar 'text-popped
1324 #'(lambda (context-id text)
1325 (declare (ignore context-id))
1326 (format nil "Popped: ~A~%" text)))
1327
1328 (make-instance 'v-box
1329 :parent window
1330 :child (make-instance 'v-box
1331 :border-width 10 :spacing 10
1332 :child (create-button "push something"
1333 #'(lambda ()
1334 (statusbar-push statusbar 1
1335 (format nil "something ~D" (incf counter)))))
1336 :child (create-button "pop"
1337 #'(lambda ()
1338 (statusbar-pop statusbar 1)))
1339 :child (create-button "steal #4"
1340 #'(lambda ()
1341 (statusbar-remove statusbar 1 4)))
1342 :child (create-button "dump stack")
1343 :child (create-button "test contexts"))
1344 :child (list (make-instance 'h-separator) :expand nil)
1345 :child (list
1346 (make-instance 'v-box :border-width 10 :child close-button)
1347 :expand nil)
1348 :child (list statusbar :expand nil))
1349
1350 (widget-grab-focus close-button)))
0d07716f 1351
1352
1353;;; Idle test
1354
e025589b 1355(define-simple-dialog create-idle-test (dialog "Idle Test")
1356 (let ((label (make-instance 'label
1357 :label "count: 0" :xpad 10 :ypad 10))
1358 (idle nil)
1359 (count 0))
1360 (signal-connect dialog 'destroy
1361 #'(lambda () (when idle (idle-remove idle))))
0d07716f 1362
e025589b 1363 (make-instance 'v-box
6490e9f1 1364 :parent dialog :border-width 10 :spacing 10
e025589b 1365 :child label
1366 :child (make-instance 'frame
1367 :label "Label Container" :border-width 5
1368 :child(make-instance 'v-box
8179fd68 1369 :children (make-radio-group 'radio-button
1370 '((:label "Resize-Parent" :value :parent :active t)
1371 (:label "Resize-Queue" :value :queue)
1372 (:label "Resize-Immediate" :value :immediate))
e025589b 1373 #'(lambda (mode)
1374 (setf
1375 (container-resize-mode (dialog-action-area dialog)) mode))))))
1376
1377 (dialog-add-button dialog "Start"
1378 #'(lambda ()
1379 (unless idle
1380 (setq idle
1381 (idle-add
1382 #'(lambda ()
1383 (incf count)
1384 (setf (label-label label) (format nil "count: ~D" count))
1385 t))))))
0d07716f 1386
e025589b 1387 (dialog-add-button dialog "Stop"
1388 #'(lambda ()
1389 (when idle
1390 (idle-remove idle)
1391 (setq idle nil))))))
0d07716f 1392
1393
1394
1395;;; Timeout test
1396
e025589b 1397(define-simple-dialog create-timeout-test (dialog "Timeout Test")
1398 (let ((label (make-instance 'label
1399 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1400 (timer nil)
1401 (count 0))
1402 (signal-connect dialog 'destroy
1403 #'(lambda () (when timer (timeout-remove timer))))
1404
1405 (dialog-add-button dialog "Start"
1406 #'(lambda ()
1407 (unless timer
1408 (setq timer
1409 (timeout-add 100
1410 #'(lambda ()
1411 (incf count)
1412 (setf (label-label label) (format nil "count: ~D" count))
1413 t))))))
1414
1415 (dialog-add-button dialog "Stop"
1416 #'(lambda ()
1417 (when timer
1418 (timeout-remove timer)
1419 (setq timer nil))))))
7932cfab 1420
1421
1422;;; Text
1423
1424(define-simple-dialog create-text (dialog "Text" :default-width 400
1425 :default-height 400)
81f2aa93 1426 (let* ((text-view (make-instance 'text-view
1427 :border-width 10 :visible t :wrap-mode :word))
1428 (buffer (text-view-buffer text-view))
1429 (active-tags ()))
1430
1431 (text-buffer-create-tag buffer "Bold" :weight :bold)
1432 (text-buffer-create-tag buffer "Italic" :style :italic)
1433 (text-buffer-create-tag buffer "Underline" :underline :single)
1434
1435 (flet ((create-toggle-callback (tag-name)
1436 (let ((tag (text-tag-table-lookup
1437 (text-buffer-tag-table buffer) tag-name)))
1438 #'(lambda (active)
1439 (unless (eq (and (find tag active-tags) t) active)
1440 ;; user activated
1441 (if active
1442 (push tag active-tags)
1443 (setq active-tags (delete tag active-tags)))
ab652f5f 1444 (multiple-value-bind (non-zero-p start end)
1445 (text-buffer-get-selection-bounds buffer)
6490e9f1 1446 (declare (ignore non-zero-p))
81f2aa93 1447 (if active
1448 (text-buffer-apply-tag buffer tag start end)
1449 (text-buffer-remove-tag buffer tag start end))))))))
1450
1451 (let* ((actions
1452 (make-instance 'action-group
1453 :action (create-toggle-action
1454 "Bold" "gtk-bold" "Bold" "<control>B" "Bold" nil
1455 (create-toggle-callback "Bold"))
1456 :action (create-toggle-action
1457 "Italic" "gtk-italic" "Italic" "<control>I" "Italic" nil
1458 (create-toggle-callback "Italic"))
1459 :action (create-toggle-action
1460 "Underline" "gtk-underline" "Underline" "<control>U" "Underline" nil
1461 (create-toggle-callback "Underline"))))
1462 (ui (make-instance 'ui-manager)))
1463
1464 (ui-manager-insert-action-group ui actions)
1465 (ui-manager-add-ui ui
1466 '((:toolbar "ToolBar"
1467 (:toolitem "Bold")
1468 (:toolitem "Italic")
1469 (:toolitem "Underline"))))
1470
1471 ;; Callback to activate/deactivate toolbar buttons when cursor
1472 ;; is moved
1473 (signal-connect buffer 'mark-set
1474 #'(lambda (location mark)
1475 (declare (ignore mark))
1476 (text-tag-table-foreach (text-buffer-tag-table buffer)
1477 #'(lambda (tag)
1478 (let ((active
1479 (or
1480 (and
1481 (text-iter-has-tag-p location tag)
1482 (not (text-iter-begins-tag-p location tag)))
1483 (text-iter-ends-tag-p location tag))))
1484 (unless (eq active (and (find tag active-tags) t))
1485 (if active
1486 (push tag active-tags)
1487 (setq active-tags (delete tag active-tags)))
1488 (setf
1489 (toggle-action-active-p
1490 (action-group-get-action actions (text-tag-name tag)))
1491 active)))))))
1492
1493 ;; Callback to apply active tags when a character is inserted
1494 (signal-connect buffer 'insert-text
1495 #'(lambda (iter &rest args)
1496 (declare (ignore args))
1497 (let ((before (text-buffer-get-iter-at-offset buffer
1498 (1- (text-iter-offset iter)))))
1499 (loop
1500 for tag in active-tags
1501 do (text-buffer-apply-tag buffer tag before iter))))
1502 :after t)
1503
1504 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1505 (container-add dialog text-view)))))
1506
0d07716f 1507
0d07716f 1508;;; Toggle buttons
1509
35ec512c 1510(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1511 (make-instance 'v-box
6490e9f1 1512 :border-width 10 :spacing 10 :parent dialog
35ec512c 1513 :children (loop
1514 for n from 1 to 3
1515 collect (make-instance 'toggle-button
1516 :label (format nil "Button~D" (1+ n))))))
0d07716f 1517
1518
1519
1520;;; Toolbar test
1521
ab652f5f 1522(defun create-toolbar (window)
8179fd68 1523 (make-instance 'toolbar
ab652f5f 1524 :show-tooltips t :show-arrow nil
8179fd68 1525
1526 ;; Insert a stock item
1527 :child (make-instance 'tool-button
1528 :stock "gtk-quit"
1529 :tip-text "Destroy toolbar"
1530 :tip-private "Toolbar/Quit"
1531 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1532
1533 :child (make-instance 'separator-tool-item)
1534
1535 :child (make-instance 'tool-button
1536 :label "Horizontal" :stock "gtk-go-forward"
1537 :tip-text "Horizontal toolbar layout"
1538 :tip-private "Toolbar/Horizontal"
1539 :signal (list 'clicked
1540 #'(lambda (toolbar)
1541 (setf (toolbar-orientation toolbar) :horizontal))
1542 :object :parent))
1543
1544 :child (make-instance 'tool-button
1545 :label "Vertical" :stock "gtk-go-down"
1546 :tip-text "Vertical toolbar layout"
1547 :tip-private "Toolbar/Vertical"
1548 :signal (list 'clicked
1549 #'(lambda (toolbar)
1550 (setf (toolbar-orientation toolbar) :vertical))
1551 :object :parent))
1552
1553 :child (make-instance 'separator-tool-item)
1554
1555 :children (make-radio-group 'radio-tool-button
1556 '((:label "Icons" :stock "gtk-justify-left"
1557 :tip-text "Only show toolbar icons"
1558 :tip-private "Toolbar/IconsOnly"
1559 :value :icons)
1560 (:label "Both" :stock "gtk-justify-center"
1561 :tip-text "Show toolbar icons and text"
1562 :tip-private "Toolbar/Both"
1563 :value :both :active t)
1564 (:label "Text" :stock "gtk-justify-right"
1565 :tip-text "Show toolbar text"
1566 :tip-private "Toolbar/TextOnly"
1567 :value :text))
1568 (list
1569 #'(lambda (toolbar style)
1570 (setf (toolbar-style toolbar) style))
1571 :object :parent))
1572
1573 :child (make-instance 'separator-tool-item)
1574
1575 :child (make-instance 'tool-item
1576 :child (make-instance 'entry)
1577 :tip-text "This is an unusable GtkEntry"
1578 :tip-private "Hey don't click me!")
1579
1580 :child (make-instance 'separator-tool-item)
1581
1582 :child (make-instance 'tool-button
1583 :label "Enable" :stock "gtk-add"
1584 :tip-text "Enable tooltips"
1585 :tip-private "Toolbar/EnableTooltips"
1586 :signal (list 'clicked
1587 #'(lambda (toolbar)
1588 (setf (toolbar-show-tooltips-p toolbar) t))
1589 :object :parent))
1590
1591 :child (make-instance 'tool-button
1592 :label "Disable" :stock "gtk-remove"
1593 :tip-text "Disable tooltips"
1594 :tip-private "Toolbar/DisableTooltips"
1595 :signal (list 'clicked
1596 #'(lambda (toolbar)
1597 (setf (toolbar-show-tooltips-p toolbar) nil))
1598 :object :parent))
1599
1600;; :child (make-instance 'separator-tool-item)
1601
1602;; :child (make-instance 'tool-button
1603;; :label "GTK" :icon #p"clg:examples;gtk.png"
1604;; :tip-text "GTK+ Logo"
1605;; :tip-private "Toolbar/GTK+")
1606 ))
0d07716f 1607
ab652f5f 1608(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1609 (container-add window (create-toolbar window)))
1610
0d07716f 1611
1612
1613;;; Tooltips test
1614
e025589b 1615(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1616 (let ((tooltips (make-instance 'tooltips)))
1617 (flet ((create-button (label tip-text tip-private)
1618 (let ((button (make-instance 'toggle-button :label label)))
1619 (tooltips-set-tip tooltips button tip-text tip-private)
1620 button)))
1621 (make-instance 'v-box
6490e9f1 1622 :parent dialog :border-width 10 :spacing 10
e025589b 1623 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
7c1f9a1e 1624 :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
7932cfab 1625
1626
1627;;; UI Manager
1628
1629(defvar *ui-description*
1630 '((:menubar "MenuBar"
1631 (:menu "FileMenu"
1632 (:menuitem "New")
1633 (:menuitem "Open")
1634 (:menuitem "Save")
1635 (:menuitem "SaveAs")
1636 :separator
1637 (:menuitem "Quit"))
1638 (:menu "PreferencesMenu"
1639 (:menu "ColorMenu"
1640 (:menuitem "Red")
1641 (:menuitem "Green")
1642 (:menuitem "Blue"))
1643 (:menu "ShapeMenu"
1644 (:menuitem "Square")
1645 (:menuitem "Rectangle")
1646 (:menuitem "Oval"))
1647 (:menuitem "Bold"))
1648 (:menu "HelpMenu"
1649 (:menuitem "About")))
1650 (:toolbar "ToolBar"
1651 (:toolitem "Open")
1652 (:toolitem "Quit")
1653 (:separator "Sep1")
1654 (:toolitem "Logo"))))
1655
81f2aa93 1656(define-toplevel create-ui-manager (window "UI Manager")
7932cfab 1657 (let ((actions
1658 (make-instance 'action-group
1659 :name "Actions"
1660 :action (create-action "FileMenu" nil "_File")
1661 :action (create-action "PreferencesMenu" nil "_Preferences")
1662 :action (create-action "ColorMenu" nil "_Color")
1663 :action (create-action "ShapeMenu" nil "_Shape")
1664 :action (create-action "HelpMenu" nil "_Help")
1665 :action (create-action "New" "gtk-new" "_New" "<control>N" "Create a new file")
81f2aa93 1666 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
7932cfab 1667 :action (create-action "Save" "gtk-save" "_Save" "<control>S" "Save current file")
1668 :action (create-action "SaveAs" "gtk-save" "Save _As..." "" "Save to a file")
81f2aa93 1669 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
7932cfab 1670 :action (create-action "About" nil "_About" "<control>A" "About")
1671 :action (create-action "Logo" "demo-gtk-logo" "" nil "GTK+")
1672 :action (create-toggle-action "Bold" "gtk-bold" "_Bold" "<control>B" "Bold" t)
1673 :actions (create-radio-actions
1674 '(("Red" nil "_Red" "<control>R" "Blood")
1675 ("Green" nil "_Green" "<control>G" "Grass")
1676 ("Blue" nil "_Blue" "<control>B" "Sky"))
1677 "Green")
1678 :actions (create-radio-actions
1679 '(("Square" nil "_Square" "<control>S" "Square")
1680 ("Rectangle" nil "_Rectangle" "<control>R" "Rectangle")
1681 ("Oval" nil "_Oval" "<control>O" "Egg")))))
1682 (ui (make-instance 'ui-manager)))
1683
1684 (ui-manager-insert-action-group ui actions)
1685 (ui-manager-add-ui ui *ui-description*)
1686
81f2aa93 1687 (window-add-accel-group window (ui-manager-accel-group ui))
7932cfab 1688
1689 (make-instance 'v-box
6490e9f1 1690 :parent window
7932cfab 1691 :child (list
1692 (ui-manager-get-widget ui "/MenuBar")
1693 :expand nil :fill nil)
1694 :child (list
1695 (ui-manager-get-widget ui "/ToolBar")
1696 :expand nil :fill nil)
1697 :child (make-instance 'label
1698 :label "Type <alt> to start"
1699 :xalign 0.5 :yalign 0.5
1700 :width-request 200 :height-request 200))))
0d07716f 1701
1702
1703
0d07716f 1704;;; Main window
1705
1706(defun create-main-window ()
35ec512c 1707;; (rc-parse "clg:examples;testgtkrc2")
1708;; (rc-parse "clg:examples;testgtkrc")
4fb50b71 1709
1710 (let* ((button-specs
0d07716f 1711 '(("button box" create-button-box)
35ec512c 1712 ("buttons" create-buttons)
1713 ("calendar" create-calendar)
1714 ("check buttons" create-check-buttons)
35ec512c 1715 ("color selection" create-color-selection)
af5eb952 1716 ("cursors" create-cursors)
35ec512c 1717 ("dialog" create-dialog)
1718;; ; ("dnd")
1719 ("entry" create-entry)
1720;; ("event watcher")
36c95ad8 1721 ("enxpander" create-expander)
35ec512c 1722 ("file chooser" create-file-chooser)
b9d3ad20 1723 ("font selection" create-font-selection)
ab652f5f 1724 ("handle box" create-handle-box)
35ec512c 1725 ("image" create-image)
35ec512c 1726 ("labels" create-labels)
1727 ("layout" create-layout)
549265c1 1728 ("list" create-list)
0d07716f 1729 ("menus" create-menus)
35ec512c 1730;; ("modal window")
1731 ("notebook" create-notebook)
1732 ("panes" create-panes)
8804934b 1733 ("progress bar" create-progress-bar)
35ec512c 1734 ("radio buttons" create-radio-buttons)
1735 ("range controls" create-range-controls)
1736;; ("rc file")
1737 ("reparent" create-reparent)
1738 ("rulers" create-rulers)
1739;; ("saved position")
1740 ("scrolled windows" create-scrolled-windows)
81f2aa93 1741 ("size group" create-size-group)
83bab9b6 1742 ("shapes" create-shapes)
35ec512c 1743 ("spinbutton" create-spins)
5ff67599 1744 ("statusbar" create-statusbar)
e025589b 1745 ("test idle" create-idle-test)
35ec512c 1746;; ("test mainloop")
1747;; ("test scrolling")
1748;; ("test selection")
e025589b 1749 ("test timeout" create-timeout-test)
7932cfab 1750 ("text" create-text)
35ec512c 1751 ("toggle buttons" create-toggle-buttons)
ab652f5f 1752 ("toolbar" create-toolbar-window)
e025589b 1753 ("tooltips" create-tooltips)
35ec512c 1754;; ("tree" #|create-tree|#)
7932cfab 1755 ("UI manager" create-ui-manager)
35ec512c 1756))
1757 (main-window (make-instance 'window
1758 :title "testgtk.lisp" :name "main_window"
1759 :default-width 200 :default-height 400
1760 :allow-grow t :allow-shrink nil))
1761 (scrolled-window (make-instance 'scrolled-window
1762 :hscrollbar-policy :automatic
1763 :vscrollbar-policy :automatic
1764 :border-width 10))
1765 (close-button (make-instance 'button
1766 :label "close" :can-default t
1767 :signal (list 'clicked #'widget-destroy
1768 :object main-window))))
0d07716f 1769
8804934b 1770 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1771 (setf
1772 (window-icon main-window)
1773 (gdk:pixbuf-add-alpha icon t 254 254 252)))
7c1f9a1e 1774
0d07716f 1775 ;; Main box
35ec512c 1776 (make-instance 'v-box
0d07716f 1777 :parent main-window
35ec512c 1778 :child-args '(:expand nil)
1779 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
1780 :child (list (make-instance 'label :label "clg CVS version") :fill nil)
41aa9108 1781 :child (list (make-instance 'label
1782 :label #-cmu(format nil "~A (~A)"
1783 (lisp-implementation-type)
1784 (lisp-implementation-version))
1785 ;; The version string in CMUCL is far too long
1786 #+cmu(lisp-implementation-type))
1787 :fill nil)
35ec512c 1788 :child (list scrolled-window :expand t)
1789 :child (make-instance 'h-separator)
1790 :child (make-instance 'v-box
1791 :homogeneous nil :spacing 10 :border-width 10
1792 :child close-button))
1793
1794 (let ((content-box
1795 (make-instance 'v-box
1796 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1797 :children (mapcar #'(lambda (spec)
1798 (apply #'create-button spec))
1799 button-specs))))
1800 (scrolled-window-add-with-viewport scrolled-window content-box))
0d07716f 1801
35ec512c 1802 (widget-grab-focus close-button)
0d07716f 1803 (widget-show-all main-window)
1804 main-window))
1805
35ec512c 1806(clg-init)
1807(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).