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