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