chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
All alien strings automatically converted to and from utf8 i SBCL
[clg] / examples / testgtk.lisp
CommitLineData
560af5c5 1;; Common Lisp bindings for GTK+ v2.0
787721b6 2;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users.sf.net>
560af5c5 3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
58d925ab 18;; $Id: testgtk.lisp,v 1.25 2005-03-13 18:16:08 espen Exp $
560af5c5 19
58d925ab 20(defpackage "TESTGTK"
21 (:use "COMMON-LISP" "GTK"))
704a1de4 22
58d925ab 23(in-package "TESTGTK")
704a1de4 24
25(defmacro define-toplevel (name (window title &rest initargs) &body body)
26 `(let ((,window nil))
560af5c5 27 (defun ,name ()
704a1de4 28 (unless ,window
f6ebddea 29 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
704a1de4 30 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
560af5c5 31 ,@body)
32
58d925ab 33 (when ,window
34 (if (not (widget-visible-p ,window))
35 (widget-show ,window)
36 (widget-hide ,window))))))
704a1de4 37
560af5c5 38
704a1de4 39(defmacro define-dialog (name (dialog title &optional (class 'dialog)
40 &rest initargs)
41 &body body)
42 `(let ((,dialog nil))
560af5c5 43 (defun ,name ()
704a1de4 44 (unless ,dialog
f6ebddea 45 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
704a1de4 46 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
47 ,@body)
560af5c5 48
58d925ab 49 (when ,dialog
50 (if (not (widget-visible-p ,dialog))
51 (widget-show ,dialog)
52 (widget-hide ,dialog))))))
560af5c5 53
54
704a1de4 55(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
56 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
bdc1babf 57 ,@body
58 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
560af5c5 59
60
560af5c5 61
62;;; Pixmaps used in some of the tests
63
64(defvar gtk-mini-xpm
196fe1e9 65 #("15 20 17 1"
560af5c5 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
196fe1e9 105 #("16 16 6 1"
560af5c5 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
196fe1e9 130 #("16 16 4 1"
560af5c5 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
196fe1e9 153 #("16 16 4 1"
560af5c5 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
196fe1e9 179(defun create-bbox-in-frame (class frame-label spacing width height layout)
704a1de4 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
977a550d 185 :child (make-instance 'button :stock "gtk-ok")
186 :child (make-instance 'button :stock "gtk-cancel")
187 :child (make-instance 'button :stock "gtk-help"))))
704a1de4 188
189(define-toplevel create-button-box (window "Button Boxes")
190 (make-instance 'v-box
f6ebddea 191 :parent window :border-width 10 :spacing 10
704a1de4 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)))))))
196fe1e9 216
217
218;; Buttons
219
704a1de4 220(define-simple-dialog create-buttons (dialog "Buttons")
196fe1e9 221 (let ((table (make-instance 'table
704a1de4 222 :n-rows 3 :n-columns 3 :homogeneous nil
196fe1e9 223 :row-spacing 5 :column-spacing 5 :border-width 10
704a1de4 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
196fe1e9 230 (dotimes (column 3)
231 (dotimes (row 3)
704a1de4 232 (let ((button (nth (+ (* 3 row) column) buttons))
233 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
196fe1e9 234 (signal-connect button 'clicked
235 #'(lambda ()
236 (if (widget-visible-p button+1)
237 (widget-hide button+1)
238 (widget-show button+1))))
33f468b7 239 (table-attach table button column (1+ column) row (1+ row)
f6ebddea 240 :options '(:expand :fill)))))))
560af5c5 241
242
243;; Calenadar
244
704a1de4 245(define-simple-dialog create-calendar (dialog "Calendar")
246 (make-instance 'v-box
f6ebddea 247 :parent dialog :border-width 10
704a1de4 248 :child (make-instance 'calendar)))
560af5c5 249
250
251;;; Check buttons
252
704a1de4 253(define-simple-dialog create-check-buttons (dialog "Check Buttons")
254 (make-instance 'v-box
f6ebddea 255 :border-width 10 :spacing 10 :parent dialog
704a1de4 256 :children (loop
257 for n from 1 to 3
258 collect (make-instance 'check-button
259 :label (format nil "Button~D" n)))))
560af5c5 260
261
262
263;;; Color selection
264
704a1de4 265(define-dialog create-color-selection (dialog "Color selection dialog"
266 'color-selection-dialog
f6ebddea 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)))))
704a1de4 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))))
560af5c5 290
704a1de4 291 (signal-connect dialog :cancel #'widget-destroy :object t)))
560af5c5 292
560af5c5 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
aa9ceddc 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)
977a550d 311 (widget-get-size-allocation drawing-area)
aa9ceddc 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
4280ef98 333 :events '(:exposure :button-press)))
aa9ceddc 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)
510fbcc1 341 (1 (spin-button-spin spinner :step-forward))
342 (3 (spin-button-spin spinner :step-backward)))
aa9ceddc 343 t))
560af5c5 344
aa9ceddc 345 (signal-connect drawing-area 'scroll-event
346 #'(lambda (event)
347 (case (gdk:event-direction event)
510fbcc1 348 (:up (spin-button-spin spinner :step-forward))
349 (:down (spin-button-spin spinner :step-backward)))
aa9ceddc 350 t))
560af5c5 351
aa9ceddc 352 (signal-connect spinner 'changed
353 #'(lambda ()
354 (set-cursor spinner drawing-area label)))
560af5c5 355
aa9ceddc 356 (make-instance 'v-box
f6ebddea 357 :parent dialog :border-width 10 :spacing 5
aa9ceddc 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
aa9ceddc 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)))
560af5c5 373
374
375;;; Dialog
376
704a1de4 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))))))
560af5c5 396
704a1de4 397 (if (widget-visible-p dialog)
398 (widget-hide dialog)
399 (widget-show dialog))))
560af5c5 400
401
402;; Entry
403
704a1de4 404(define-simple-dialog create-entry (dialog "Entry")
405 (let ((main (make-instance 'v-box
406 :border-width 10 :spacing 10 :parent dialog)))
196fe1e9 407
704a1de4 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)
196fe1e9 413
613fb570 414 (let ((combo (make-instance 'combo-box-entry
704a1de4 415 :parent main
613fb570 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)))
704a1de4 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)
f6ebddea 441 (create-check-button "Sensitive" 'sensitive)))))
560af5c5 442
560af5c5 443
96b68e83 444;; Expander
445
446(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
447 (make-instance 'v-box
f6ebddea 448 :parent dialog :spacing 5 :border-width 5
96b68e83 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
560af5c5 454
704a1de4 455;; File chooser dialog
560af5c5 456
704a1de4 457(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
c5502496 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
704a1de4 464 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
465 (dialog-add-button dialog "gtk-ok"
466 #'(lambda ()
842e5ffe 467 (if (slot-boundp dialog 'filename)
812dd869 468 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
469 (write-line "No files selected"))
704a1de4 470 (widget-destroy dialog))))
560af5c5 471
472
3f315085 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
560af5c5 482
483;;; Handle box
484
842e5ffe 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")))
704a1de4 504
58d925ab 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
704a1de4 621;;; Image
560af5c5 622
40a3dac5 623(define-toplevel create-image (window "Image" :resizable nil)
704a1de4 624 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5 625
626
627;;; Labels
628
704a1de4 629(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9 630 (flet ((create-label-in-frame (frame-label label-text &rest args)
631 (list
632 (make-instance 'frame
633 :label frame-label
704a1de4 634 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
196fe1e9 635 :fill nil :expand nil)))
704a1de4 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"
560af5c5 643"This is a Multi-line label.
644Second line
196fe1e9 645Third line")
704a1de4 646 :child (create-label-in-frame "Left Justified Label"
560af5c5 647"This is a Left-Justified
648Multi-line.
196fe1e9 649Third line"
704a1de4 650 :justify :left)
651 :child (create-label-in-frame "Right Justified Label"
560af5c5 652"This is a Right-Justified
653Multi-line.
196fe1e9 654Third line"
704a1de4 655 :justify :right))
656 :child (make-instance 'v-box
657 :spacing 5
658 :child (create-label-in-frame "Line wrapped label"
560af5c5 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.
196fe1e9 660 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4 661 :wrap t)
662
663 :child (create-label-in-frame "Filled, wrapped label"
560af5c5 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.
196fe1e9 666 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4 667 :justify :fill :wrap t)
668
669 :child (create-label-in-frame "Underlined label"
560af5c5 670"This label is underlined!
196fe1e9 671This one is underlined (こんにちは) in quite a funky fashion"
704a1de4 672 :justify :left
673 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
560af5c5 674
675
676;;; Layout
677
aa9ceddc 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)
704a1de4 697
698(define-toplevel create-layout (window "Layout" :default-width 200
699 :default-height 200)
196fe1e9 700 (let ((layout (make-instance 'layout
701 :parent (make-instance 'scrolled-window :parent window)
4280ef98 702 :width 1600 :height 128000 :events '(:exposure)
f6ebddea 703 :signal (list 'expose-event #'layout-expose :object t))))
196fe1e9 704
705 (with-slots (hadjustment vadjustment) layout
706 (setf
707 (adjustment-step-increment hadjustment) 10.0
708 (adjustment-step-increment vadjustment) 10.0))
560af5c5 709
710 (dotimes (i 16)
711 (dotimes (j 16)
704a1de4 712 (let ((text (format nil "Button ~D, ~D" i j)))
f6ebddea 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)))))
560af5c5 719
704a1de4 720 (loop
721 for i from 16 below 1280
722 do (let ((text (format nil "Button ~D, ~D" i 0)))
f6ebddea 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))))))
196fe1e9 729
560af5c5 730
731
732;;; List
733
21f6214a 734(define-simple-dialog create-list (dialog "List" :default-height 400)
d975a970 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)))
560af5c5 741
21f6214a 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))
d975a970 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
f6ebddea 766 :parent dialog :border-width 10 :spacing 10
d975a970 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))))
560af5c5 823
824
825;; Menus
826
827(defun create-menu (depth tearoff)
828 (unless (zerop depth)
704a1de4 829 (let ((menu (make-instance 'menu)))
560af5c5 830 (when tearoff
704a1de4 831 (let ((menu-item (make-instance 'tearoff-menu-item)))
832 (menu-shell-append menu menu-item)))
560af5c5 833 (let ((group nil))
834 (dotimes (i 5)
704a1de4 835 (let ((menu-item
836 (make-instance 'radio-menu-item
837 :label (format nil "item ~2D - ~D" depth (1+ i)))))
838 (if group
842e5ffe 839 (add-to-radio-group menu-item group)
704a1de4 840 (setq group menu-item))
560af5c5 841 (unless (zerop (mod depth 2))
704a1de4 842 (setf (check-menu-item-active-p menu-item) t))
843 (menu-shell-append menu menu-item)
560af5c5 844 (when (= i 3)
704a1de4 845 (setf (widget-sensitive-p menu-item) nil))
977a550d 846 (let ((submenu (create-menu (1- depth) t)))
847 (when submenu
848 (setf (menu-item-submenu menu-item) submenu))))))
196fe1e9 849 menu)))
560af5c5 850
851
704a1de4 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))))
842e5ffe 856; (window-add-accel-group dialog accel-group)
704a1de4 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
613fb570 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))))
560af5c5 879
613fb570 880 (widget-show-all main)))
560af5c5 881
882
883;;; Notebook
884
977a550d 885(defun create-notebook-page (notebook page-num book-closed)
704a1de4 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
f6ebddea 925 :show-children t
704a1de4 926 :child-args '(:expand nil)
977a550d 927 :child (make-instance 'image :pixbuf book-closed)
704a1de4 928 :child (make-instance 'label :label title)))
929 (menu-box (make-instance 'h-box
f6ebddea 930 :show-children t
704a1de4 931 :child-args '(:expand nil)
977a550d 932 :child (make-instance 'image :pixbuf book-closed)
704a1de4 933 :child (make-instance 'label :label title))))
934
935 (widget-show-all page)
936 (notebook-append notebook page label-box menu-box))))
560af5c5 937
560af5c5 938
704a1de4 939(define-simple-dialog create-notebook (dialog "Notebook")
940 (let ((main (make-instance 'v-box :parent dialog)))
977a550d 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
704a1de4 944 :border-width 10 :tab-pos :top :parent main)))
977a550d 945 (flet ((set-image (page func pixbuf)
946 (setf
947 (image-pixbuf
948 (first (container-children (funcall func notebook page))))
949 pixbuf)))
704a1de4 950 (signal-connect notebook 'switch-page
951 #'(lambda (pointer page)
952 (declare (ignore pointer))
842e5ffe 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)
704a1de4 956 (let ((curpage (notebook-current-page notebook)))
842e5ffe 957 (set-image curpage #'notebook-menu-label book-closed)
958 (set-image curpage #'notebook-tab-label book-closed))))))
977a550d 959 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
704a1de4 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))
613fb570 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
977a550d 1015 do (create-notebook-page notebook i book-closed))))))
613fb570 1016 :object t)))
704a1de4 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)))
560af5c5 1042
1043
1044;;; Panes
1045
1046(defun toggle-resize (child)
812dd869 1047 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
560af5c5 1048
1049(defun toggle-shrink (child)
812dd869 1050 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
560af5c5 1051
1052(defun create-pane-options (paned frame-label label1 label2)
812dd869 1053 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
33f468b7 1054 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
704a1de4 1055 (let ((check-button (make-instance 'check-button :label "Resize")))
33f468b7 1056 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
812dd869 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)))
33f468b7 1060 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
812dd869 1061 (signal-connect check-button 'toggled
1062 #'toggle-shrink :object (paned-child1 paned)))
560af5c5 1063
33f468b7 1064 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
812dd869 1065 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
33f468b7 1066 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
812dd869 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)))
33f468b7 1070 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
812dd869 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)))
560af5c5 1074
704a1de4 1075(define-toplevel create-panes (window "Panes")
1076 (let* ((hpaned (make-instance 'h-paned
196fe1e9 1077 :child1 (make-instance 'frame
704a1de4 1078 :width-request 60 :height-request 60
1079 :shadow-type :in
812dd869 1080 :child (make-instance 'button :label "Hi there"))
704a1de4 1081 :child2 (make-instance 'frame
1082 :width-request 80 :height-request 60
1083 :shadow-type :in)))
1084 (vpaned (make-instance 'v-paned
196fe1e9 1085 :border-width 5
1086 :child1 hpaned
1087 :child2 (make-instance 'frame
704a1de4 1088 :width-request 80 :height-request 60
1089 :shadow-type :in))))
196fe1e9 1090
704a1de4 1091 (make-instance 'v-box
196fe1e9 1092 :parent window
704a1de4 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"))))
560af5c5 1097
1098
560af5c5 1099;;; Progress bar
1100
977a550d 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
f6ebddea 1118 :parent dialog :border-width 10 :spacing 10
977a550d 1119 :child progress
1120 :child activity-mode-button)
1121
1122 (signal-connect dialog 'destroy
1123 #'(lambda () (when timer (timeout-remove timer))))))
560af5c5 1124
1125
1126;;; Radio buttons
1127
704a1de4 1128(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1129 (make-instance 'v-box
f6ebddea 1130 :parent dialog :border-width 10 :spacing 10
787721b6 1131 :children (make-radio-group 'radio-button
1132 '((:label "button1") (:label "button2") (:label "button3"))
1133 nil)))
560af5c5 1134
1135
1136;;; Rangle controls
1137
704a1de4 1138(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1139 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 1140 (make-instance 'v-box
f6ebddea 1141 :parent dialog :border-width 10 :spacing 10
704a1de4 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))))
560af5c5 1147
1148
1149;;; Reparent test
1150
704a1de4 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))
977a550d 1154 (label (make-instance 'label :label "Hello World")))
560af5c5 1155
704a1de4 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)))
560af5c5 1166
704a1de4 1167 (box-pack-start (create-frame "Frame 1") label nil t 0)
1168 (create-frame "Frame 2"))
1169 (widget-show-all main)))
560af5c5 1170
1171
1172;;; Rulers
1173
704a1de4 1174(define-toplevel create-rulers (window "Rulers"
1175 :default-width 300 :default-height 300
4280ef98 1176 :events '(:pointer-motion :pointer-motion-hint))
33f468b7 1177 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1178 (h-ruler (make-instance 'h-ruler
704a1de4 1179 :metric :centimeters :lower 100.0d0 :upper 0.0d0
33f468b7 1180 :position 0.0d0 :max-size 20.0d0))
1181 (v-ruler (make-instance 'v-ruler
704a1de4 1182 :lower 5.0d0 :upper 15.0d0
1183 :position 0.0d0 :max-size 20.0d0)))
33f468b7 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)))
560af5c5 1190
1191
1192;;; Scrolled window
1193
704a1de4 1194(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1195 :default-width 300
1196 :default-height 300)
196fe1e9 1197 (let* ((scrolled-window
1198 (make-instance 'scrolled-window
704a1de4 1199 :parent dialog :border-width 10
1200 :vscrollbar-policy :automatic
196fe1e9 1201 :hscrollbar-policy :automatic))
1202 (table
1203 (make-instance 'table
704a1de4 1204 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1205 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1206 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1207
560af5c5 1208 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1209 (dotimes (i 20)
1210 (dotimes (j 20)
1211 (let ((button
704a1de4 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)))
560af5c5 1216
1217
33f468b7 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
f6ebddea 1239 :parent dialog :border-width 5 :spacing 5
33f468b7 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
560af5c5 1254;;; Shapes
1255
9257d518 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))))
196fe1e9 1262
9257d518 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))
196fe1e9 1268
9257d518 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)))
560af5c5 1286
9257d518 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))))))
560af5c5 1294
9257d518 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)))))
560af5c5 1328
1329
1330
1331;;; Spin buttons
1332
704a1de4 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))))
40a3dac5 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)))))
704a1de4 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)))
560af5c5 1432
704a1de4 1433
c775862e 1434;;; Statusbar
560af5c5 1435
c775862e 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)))
560af5c5 1470
1471
1472;;; Idle test
1473
bdc1babf 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))))
560af5c5 1481
bdc1babf 1482 (make-instance 'v-box
f6ebddea 1483 :parent dialog :border-width 10 :spacing 10
bdc1babf 1484 :child label
1485 :child (make-instance 'frame
1486 :label "Label Container" :border-width 5
1487 :child(make-instance 'v-box
787721b6 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))
bdc1babf 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))))))
560af5c5 1505
bdc1babf 1506 (dialog-add-button dialog "Stop"
1507 #'(lambda ()
1508 (when idle
1509 (idle-remove idle)
1510 (setq idle nil))))))
560af5c5 1511
1512
1513
1514;;; Timeout test
1515
bdc1babf 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))))))
dddfc333 1539
1540
1541;;; Text
1542
1543(define-simple-dialog create-text (dialog "Text" :default-width 400
1544 :default-height 400)
33f468b7 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)))
842e5ffe 1563 (multiple-value-bind (non-zero-p start end)
1564 (text-buffer-get-selection-bounds buffer)
f6ebddea 1565 (declare (ignore non-zero-p))
33f468b7 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
560af5c5 1626
560af5c5 1627;;; Toggle buttons
1628
704a1de4 1629(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1630 (make-instance 'v-box
f6ebddea 1631 :border-width 10 :spacing 10 :parent dialog
704a1de4 1632 :children (loop
1633 for n from 1 to 3
1634 collect (make-instance 'toggle-button
1635 :label (format nil "Button~D" (1+ n))))))
560af5c5 1636
1637
1638
1639;;; Toolbar test
1640
842e5ffe 1641(defun create-toolbar (window)
787721b6 1642 (make-instance 'toolbar
842e5ffe 1643 :show-tooltips t :show-arrow nil
787721b6 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 ))
560af5c5 1726
842e5ffe 1727(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1728 (container-add window (create-toolbar window)))
1729
560af5c5 1730
1731
1732;;; Tooltips test
1733
bdc1babf 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
f6ebddea 1741 :parent dialog :border-width 10 :spacing 10
bdc1babf 1742 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
812dd869 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")))))
dddfc333 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
33f468b7 1775(define-toplevel create-ui-manager (window "UI Manager")
dddfc333 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")
33f468b7 1785 :action (create-action "Open" "gtk-open" "_Open" "<control>O" "Open a file" #'create-file-chooser)
dddfc333 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")
33f468b7 1788 :action (create-action "Quit" "gtk-quit" "_Quit" "<control>Q" "Quit" (list #'widget-destroy :object window))
dddfc333 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
33f468b7 1806 (window-add-accel-group window (ui-manager-accel-group ui))
dddfc333 1807
1808 (make-instance 'v-box
f6ebddea 1809 :parent window
dddfc333 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))))
560af5c5 1820
1821
1822
560af5c5 1823;;; Main window
1824
1825(defun create-main-window ()
704a1de4 1826;; (rc-parse "clg:examples;testgtkrc2")
1827;; (rc-parse "clg:examples;testgtkrc")
196fe1e9 1828
1829 (let* ((button-specs
560af5c5 1830 '(("button box" create-button-box)
704a1de4 1831 ("buttons" create-buttons)
1832 ("calendar" create-calendar)
1833 ("check buttons" create-check-buttons)
704a1de4 1834 ("color selection" create-color-selection)
aa9ceddc 1835 ("cursors" create-cursors)
704a1de4 1836 ("dialog" create-dialog)
1837;; ; ("dnd")
1838 ("entry" create-entry)
1839;; ("event watcher")
96b68e83 1840 ("enxpander" create-expander)
704a1de4 1841 ("file chooser" create-file-chooser)
3f315085 1842 ("font selection" create-font-selection)
842e5ffe 1843 ("handle box" create-handle-box)
58d925ab 1844#+gtk2.6 ("icon view" create-icon-view)
704a1de4 1845 ("image" create-image)
704a1de4 1846 ("labels" create-labels)
1847 ("layout" create-layout)
21f6214a 1848 ("list" create-list)
560af5c5 1849 ("menus" create-menus)
704a1de4 1850;; ("modal window")
1851 ("notebook" create-notebook)
1852 ("panes" create-panes)
977a550d 1853 ("progress bar" create-progress-bar)
704a1de4 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)
33f468b7 1861 ("size group" create-size-group)
9257d518 1862 ("shapes" create-shapes)
704a1de4 1863 ("spinbutton" create-spins)
c775862e 1864 ("statusbar" create-statusbar)
bdc1babf 1865 ("test idle" create-idle-test)
704a1de4 1866;; ("test mainloop")
1867;; ("test scrolling")
1868;; ("test selection")
bdc1babf 1869 ("test timeout" create-timeout-test)
dddfc333 1870 ("text" create-text)
704a1de4 1871 ("toggle buttons" create-toggle-buttons)
842e5ffe 1872 ("toolbar" create-toolbar-window)
bdc1babf 1873 ("tooltips" create-tooltips)
704a1de4 1874;; ("tree" #|create-tree|#)
dddfc333 1875 ("UI manager" create-ui-manager)
704a1de4 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))))
560af5c5 1889
977a550d 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)))
812dd869 1894
560af5c5 1895 ;; Main box
704a1de4 1896 (make-instance 'v-box
560af5c5 1897 :parent main-window
704a1de4 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)
c2ef984c 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)
704a1de4 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))
560af5c5 1921
704a1de4 1922 (widget-grab-focus close-button)
560af5c5 1923 (widget-show-all main-window)
1924 main-window))
1925
704a1de4 1926(clg-init)
1927(create-main-window)
Common Lisp bindings for GTK and friends (local modifications).