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