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