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