chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Added new function PLIST-REMOVE
[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
26;; Kimball, Josh MacDonald and others.
27
28
f5c99598 29;; $Id: testgtk.lisp,v 1.40 2007-06-20 10:20:47 espen Exp $
960aa85c 30
31#+sbcl(require :gtk)
89db7367 32#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
560af5c5 33
58d925ab 34(defpackage "TESTGTK"
ba22f655 35 (:use "COMMON-LISP" "CLG"))
704a1de4 36
58d925ab 37(in-package "TESTGTK")
704a1de4 38
39(defmacro define-toplevel (name (window title &rest initargs) &body body)
40 `(let ((,window nil))
560af5c5 41 (defun ,name ()
704a1de4 42 (unless ,window
f6ebddea 43 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
704a1de4 44 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
560af5c5 45 ,@body)
46
58d925ab 47 (when ,window
48 (if (not (widget-visible-p ,window))
49 (widget-show ,window)
50 (widget-hide ,window))))))
704a1de4 51
560af5c5 52
704a1de4 53(defmacro define-dialog (name (dialog title &optional (class 'dialog)
54 &rest initargs)
55 &body body)
56 `(let ((,dialog nil))
560af5c5 57 (defun ,name ()
704a1de4 58 (unless ,dialog
f6ebddea 59 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
704a1de4 60 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
61 ,@body)
560af5c5 62
58d925ab 63 (when ,dialog
64 (if (not (widget-visible-p ,dialog))
65 (widget-show ,dialog)
66 (widget-hide ,dialog))))))
560af5c5 67
68
704a1de4 69(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
70 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
bdc1babf 71 ,@body
72 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
560af5c5 73
74
560af5c5 75
76;;; Pixmaps used in some of the tests
77
78(defvar gtk-mini-xpm
196fe1e9 79 #("15 20 17 1"
560af5c5 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
196fe1e9 119 #("16 16 6 1"
560af5c5 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
196fe1e9 144 #("16 16 4 1"
560af5c5 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
196fe1e9 167 #("16 16 4 1"
560af5c5 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
196fe1e9 193(defun create-bbox-in-frame (class frame-label spacing width height layout)
704a1de4 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
977a550d 199 :child (make-instance 'button :stock "gtk-ok")
200 :child (make-instance 'button :stock "gtk-cancel")
201 :child (make-instance 'button :stock "gtk-help"))))
704a1de4 202
203(define-toplevel create-button-box (window "Button Boxes")
204 (make-instance 'v-box
f6ebddea 205 :parent window :border-width 10 :spacing 10
704a1de4 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)))))))
196fe1e9 230
231
232;; Buttons
233
704a1de4 234(define-simple-dialog create-buttons (dialog "Buttons")
196fe1e9 235 (let ((table (make-instance 'table
704a1de4 236 :n-rows 3 :n-columns 3 :homogeneous nil
196fe1e9 237 :row-spacing 5 :column-spacing 5 :border-width 10
704a1de4 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
196fe1e9 244 (dotimes (column 3)
245 (dotimes (row 3)
704a1de4 246 (let ((button (nth (+ (* 3 row) column) buttons))
247 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
196fe1e9 248 (signal-connect button 'clicked
249 #'(lambda ()
250 (if (widget-visible-p button+1)
251 (widget-hide button+1)
252 (widget-show button+1))))
33f468b7 253 (table-attach table button column (1+ column) row (1+ row)
f6ebddea 254 :options '(:expand :fill)))))))
560af5c5 255
256
257;; Calenadar
258
704a1de4 259(define-simple-dialog create-calendar (dialog "Calendar")
260 (make-instance 'v-box
f6ebddea 261 :parent dialog :border-width 10
704a1de4 262 :child (make-instance 'calendar)))
560af5c5 263
264
265;;; Check buttons
266
704a1de4 267(define-simple-dialog create-check-buttons (dialog "Check Buttons")
268 (make-instance 'v-box
f6ebddea 269 :border-width 10 :spacing 10 :parent dialog
704a1de4 270 :children (loop
271 for n from 1 to 3
272 collect (make-instance 'check-button
273 :label (format nil "Button~D" n)))))
560af5c5 274
275
276
277;;; Color selection
278
704a1de4 279(define-dialog create-color-selection (dialog "Color selection dialog"
280 'color-selection-dialog
f6ebddea 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)))))
704a1de4 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))))
560af5c5 304
704a1de4 305 (signal-connect dialog :cancel #'widget-destroy :object t)))
560af5c5 306
560af5c5 307
e898557a 308;;; Cursors (Note: using the drawing function in Gdk is considered
309;;; deprecated in clg, new code should use Cairo instead)
560af5c5 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
aa9ceddc 315(defun set-cursor (spinner drawing-area label)
316 (let ((cursor
89db7367 317 (gffi:int-enum
aa9ceddc 318 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
319 'gdk:cursor-type)))
320 (setf (label-label label) (string-downcase cursor))
89db7367 321 (widget-set-cursor drawing-area cursor)))
aa9ceddc 322
323(defun cursor-expose (drawing-area event)
324 (declare (ignore event))
325 (multiple-value-bind (width height)
977a550d 326 (widget-get-size-allocation drawing-area)
aa9ceddc 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
89db7367 344 (1- (gffi:enum-int :last-cursor 'gdk:cursor-type))
aa9ceddc 345 2 10 0)))
346 (drawing-area (make-instance 'drawing-area
347 :width-request 80 :height-request 80
4280ef98 348 :events '(:exposure :button-press)))
aa9ceddc 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)
510fbcc1 356 (1 (spin-button-spin spinner :step-forward))
357 (3 (spin-button-spin spinner :step-backward)))
aa9ceddc 358 t))
560af5c5 359
aa9ceddc 360 (signal-connect drawing-area 'scroll-event
361 #'(lambda (event)
362 (case (gdk:event-direction event)
510fbcc1 363 (:up (spin-button-spin spinner :step-forward))
364 (:down (spin-button-spin spinner :step-backward)))
aa9ceddc 365 t))
560af5c5 366
aa9ceddc 367 (signal-connect spinner 'changed
368 #'(lambda ()
369 (set-cursor spinner drawing-area label)))
560af5c5 370
aa9ceddc 371 (make-instance 'v-box
f6ebddea 372 :parent dialog :border-width 10 :spacing 5
aa9ceddc 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
aa9ceddc 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)))
560af5c5 388
389
390;;; Dialog
391
704a1de4 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))))))
560af5c5 411
704a1de4 412 (if (widget-visible-p dialog)
413 (widget-hide dialog)
414 (widget-show dialog))))
560af5c5 415
416
417;; Entry
418
704a1de4 419(define-simple-dialog create-entry (dialog "Entry")
420 (let ((main (make-instance 'v-box
421 :border-width 10 :spacing 10 :parent dialog)))
196fe1e9 422
704a1de4 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)
196fe1e9 428
613fb570 429 (let ((combo (make-instance 'combo-box-entry
704a1de4 430 :parent main
613fb570 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)))
704a1de4 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)
f6ebddea 456 (create-check-button "Sensitive" 'sensitive)))))
560af5c5 457
560af5c5 458
96b68e83 459;; Expander
460
461(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
462 (make-instance 'v-box
f6ebddea 463 :parent dialog :spacing 5 :border-width 5
96b68e83 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
560af5c5 469
704a1de4 470;; File chooser dialog
560af5c5 471
704a1de4 472(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
c5502496 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
704a1de4 479 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
480 (dialog-add-button dialog "gtk-ok"
481 #'(lambda ()
842e5ffe 482 (if (slot-boundp dialog 'filename)
812dd869 483 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
484 (write-line "No files selected"))
704a1de4 485 (widget-destroy dialog))))
560af5c5 486
487
3f315085 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
560af5c5 497
58d925ab 498;;; Icon View
499
9ba1aab1 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
89db7367 533#?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
58d925ab 534(let ((file-pixbuf nil)
535 (folder-pixbuf nil))
536 (defun load-pixbufs ()
537 (unless file-pixbuf
538 (handler-case
539 (setf
88462189 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"))
58d925ab 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)
547 :signal (list :close #'widget-destroy :object t))
548 (return-from load-pixbufs nil))))
549 t)
550
551 (defun fill-store (store directory)
9ba1aab1 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))))
58d925ab 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
89db7367 574
58d925ab 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
9ba1aab1 590 :text-column 'filename
591 :pixbuf-column 'pixbuf))
58d925ab 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
89db7367 604 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
58d925ab 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
704a1de4 635;;; Image
560af5c5 636
40a3dac5 637(define-toplevel create-image (window "Image" :resizable nil)
704a1de4 638 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5 639
640
641;;; Labels
642
704a1de4 643(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9 644 (flet ((create-label-in-frame (frame-label label-text &rest args)
89db7367 645 (make-instance 'frame
646 :label frame-label
647 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
704a1de4 648 (make-instance 'h-box
649 :spacing 5 :parent window
650 :child-args '(:fill nil :expand nil)
651 :child (make-instance 'v-box
89db7367 652 :spacing 5 :child-args '(:fill nil :expand nil)
704a1de4 653 :child (create-label-in-frame "Normal Label" "This is a Normal label")
654 :child (create-label-in-frame "Multi-line Label"
560af5c5 655"This is a Multi-line label.
656Second line
196fe1e9 657Third line")
704a1de4 658 :child (create-label-in-frame "Left Justified Label"
560af5c5 659"This is a Left-Justified
660Multi-line.
196fe1e9 661Third line"
704a1de4 662 :justify :left)
663 :child (create-label-in-frame "Right Justified Label"
560af5c5 664"This is a Right-Justified
665Multi-line.
196fe1e9 666Third line"
704a1de4 667 :justify :right))
668 :child (make-instance 'v-box
89db7367 669 :spacing 5 :child-args '(:fill nil :expand nil)
704a1de4 670 :child (create-label-in-frame "Line wrapped label"
560af5c5 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.
196fe1e9 672 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4 673 :wrap t)
674
675 :child (create-label-in-frame "Filled, wrapped label"
560af5c5 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.
196fe1e9 678 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4 679 :justify :fill :wrap t)
680
681 :child (create-label-in-frame "Underlined label"
560af5c5 682"This label is underlined!
89db7367 683This one is underlined in quite a funky fashion"
704a1de4 684 :justify :left
685 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
560af5c5 686
687
e898557a 688;;; Layout (Note: using the drawing function in Gdk is considered
689;;; deprecated in clg, new code should use Cairo instead)
560af5c5 690
aa9ceddc 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)
704a1de4 710
711(define-toplevel create-layout (window "Layout" :default-width 200
712 :default-height 200)
196fe1e9 713 (let ((layout (make-instance 'layout
714 :parent (make-instance 'scrolled-window :parent window)
4280ef98 715 :width 1600 :height 128000 :events '(:exposure)
f6ebddea 716 :signal (list 'expose-event #'layout-expose :object t))))
196fe1e9 717
718 (with-slots (hadjustment vadjustment) layout
719 (setf
720 (adjustment-step-increment hadjustment) 10.0
721 (adjustment-step-increment vadjustment) 10.0))
560af5c5 722
723 (dotimes (i 16)
724 (dotimes (j 16)
704a1de4 725 (let ((text (format nil "Button ~D, ~D" i j)))
f6ebddea 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)))))
560af5c5 732
704a1de4 733 (loop
734 for i from 16 below 1280
735 do (let ((text (format nil "Button ~D, ~D" i 0)))
f6ebddea 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))))))
196fe1e9 742
560af5c5 743
744
745;;; List
746
21f6214a 747(define-simple-dialog create-list (dialog "List" :default-height 400)
d975a970 748 (let* ((store (make-instance 'list-store
d01ac6fc 749 :column-types '(string integer boolean)
d975a970 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)))
560af5c5 754
21f6214a 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))
d975a970 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)
9ba1aab1 763 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :foo))
d975a970 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)
9ba1aab1 769 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :bar))
d975a970 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)
9ba1aab1 775 (cell-layout-add-attribute column cell 'text (tree-model-column-index store :baz))
d975a970 776 (tree-view-append-column tree column))
777
778 (make-instance 'v-box
f6ebddea 779 :parent dialog :border-width 10 :spacing 10
d975a970 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))))
560af5c5 836
837
838;; Menus
839
840(defun create-menu (depth tearoff)
841 (unless (zerop depth)
704a1de4 842 (let ((menu (make-instance 'menu)))
560af5c5 843 (when tearoff
704a1de4 844 (let ((menu-item (make-instance 'tearoff-menu-item)))
845 (menu-shell-append menu menu-item)))
560af5c5 846 (let ((group nil))
847 (dotimes (i 5)
704a1de4 848 (let ((menu-item
849 (make-instance 'radio-menu-item
850 :label (format nil "item ~2D - ~D" depth (1+ i)))))
851 (if group
842e5ffe 852 (add-to-radio-group menu-item group)
704a1de4 853 (setq group menu-item))
560af5c5 854 (unless (zerop (mod depth 2))
704a1de4 855 (setf (check-menu-item-active-p menu-item) t))
856 (menu-shell-append menu menu-item)
560af5c5 857 (when (= i 3)
704a1de4 858 (setf (widget-sensitive-p menu-item) nil))
977a550d 859 (let ((submenu (create-menu (1- depth) t)))
860 (when submenu
861 (setf (menu-item-submenu menu-item) submenu))))))
196fe1e9 862 menu)))
560af5c5 863
864
704a1de4 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))))
842e5ffe 869; (window-add-accel-group dialog accel-group)
704a1de4 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
613fb570 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))))
560af5c5 892
613fb570 893 (widget-show-all main)))
560af5c5 894
895
896;;; Notebook
897
977a550d 898(defun create-notebook-page (notebook page-num book-closed)
704a1de4 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
89db7367 937
704a1de4 938 (let ((label-box (make-instance 'h-box
f6ebddea 939 :show-children t
704a1de4 940 :child-args '(:expand nil)
977a550d 941 :child (make-instance 'image :pixbuf book-closed)
704a1de4 942 :child (make-instance 'label :label title)))
943 (menu-box (make-instance 'h-box
f6ebddea 944 :show-children t
704a1de4 945 :child-args '(:expand nil)
977a550d 946 :child (make-instance 'image :pixbuf book-closed)
704a1de4 947 :child (make-instance 'label :label title))))
948
704a1de4 949 (notebook-append notebook page label-box menu-box))))
560af5c5 950
704a1de4 951(define-simple-dialog create-notebook (dialog "Notebook")
952 (let ((main (make-instance 'v-box :parent dialog)))
977a550d 953 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
89db7367 954 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
955 (notebook (make-instance 'notebook
704a1de4 956 :border-width 10 :tab-pos :top :parent main)))
89db7367 957
977a550d 958 (flet ((set-image (page func pixbuf)
959 (setf
960 (image-pixbuf
961 (first (container-children (funcall func notebook page))))
962 pixbuf)))
704a1de4 963 (signal-connect notebook 'switch-page
964 #'(lambda (pointer page)
965 (declare (ignore pointer))
842e5ffe 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)
704a1de4 969 (let ((curpage (notebook-current-page notebook)))
842e5ffe 970 (set-image curpage #'notebook-menu-label book-closed)
971 (set-image curpage #'notebook-tab-label book-closed))))))
977a550d 972 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
704a1de4 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))
613fb570 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
977a550d 1028 do (create-notebook-page notebook i book-closed))))))
613fb570 1029 :object t)))
704a1de4 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
89db7367 1040 :label "Prev"
704a1de4 1041 :signal (list 'clicked #'notebook-prev-page :object notebook))
1042 :child (make-instance 'button
89db7367 1043 :label "Next"
704a1de4 1044 :signal (list 'clicked #'notebook-next-page :object notebook))
1045 :child (make-instance 'button
89db7367 1046 :label "Rotate"
704a1de4 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)))
560af5c5 1055
1056
89db7367 1057
560af5c5 1058;;; Panes
1059
1060(defun toggle-resize (child)
812dd869 1061 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
560af5c5 1062
1063(defun toggle-shrink (child)
812dd869 1064 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
560af5c5 1065
1066(defun create-pane-options (paned frame-label label1 label2)
812dd869 1067 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
33f468b7 1068 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
704a1de4 1069 (let ((check-button (make-instance 'check-button :label "Resize")))
33f468b7 1070 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
812dd869 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)))
33f468b7 1074 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
812dd869 1075 (signal-connect check-button 'toggled
1076 #'toggle-shrink :object (paned-child1 paned)))
560af5c5 1077
33f468b7 1078 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
812dd869 1079 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
33f468b7 1080 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
812dd869 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)))
33f468b7 1084 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
812dd869 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)))
560af5c5 1088
704a1de4 1089(define-toplevel create-panes (window "Panes")
1090 (let* ((hpaned (make-instance 'h-paned
196fe1e9 1091 :child1 (make-instance 'frame
704a1de4 1092 :width-request 60 :height-request 60
1093 :shadow-type :in
812dd869 1094 :child (make-instance 'button :label "Hi there"))
704a1de4 1095 :child2 (make-instance 'frame
1096 :width-request 80 :height-request 60
1097 :shadow-type :in)))
1098 (vpaned (make-instance 'v-paned
196fe1e9 1099 :border-width 5
1100 :child1 hpaned
1101 :child2 (make-instance 'frame
704a1de4 1102 :width-request 80 :height-request 60
1103 :shadow-type :in))))
196fe1e9 1104
704a1de4 1105 (make-instance 'v-box
196fe1e9 1106 :parent window
704a1de4 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"))))
560af5c5 1111
1112
560af5c5 1113;;; Progress bar
1114
977a550d 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
f6ebddea 1132 :parent dialog :border-width 10 :spacing 10
977a550d 1133 :child progress
1134 :child activity-mode-button)
1135
1136 (signal-connect dialog 'destroy
1137 #'(lambda () (when timer (timeout-remove timer))))))
560af5c5 1138
1139
1140;;; Radio buttons
1141
704a1de4 1142(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1143 (make-instance 'v-box
f6ebddea 1144 :parent dialog :border-width 10 :spacing 10
787721b6 1145 :children (make-radio-group 'radio-button
1146 '((:label "button1") (:label "button2") (:label "button3"))
1147 nil)))
560af5c5 1148
1149
1150;;; Rangle controls
1151
704a1de4 1152(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1153 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 1154 (make-instance 'v-box
f6ebddea 1155 :parent dialog :border-width 10 :spacing 10
704a1de4 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))))
560af5c5 1161
1162
1163;;; Reparent test
1164
704a1de4 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))
977a550d 1168 (label (make-instance 'label :label "Hello World")))
560af5c5 1169
704a1de4 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)))
560af5c5 1180
704a1de4 1181 (box-pack-start (create-frame "Frame 1") label nil t 0)
1182 (create-frame "Frame 2"))
1183 (widget-show-all main)))
560af5c5 1184
1185
1186;;; Rulers
1187
704a1de4 1188(define-toplevel create-rulers (window "Rulers"
1189 :default-width 300 :default-height 300
4280ef98 1190 :events '(:pointer-motion :pointer-motion-hint))
33f468b7 1191 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1192 (h-ruler (make-instance 'h-ruler
704a1de4 1193 :metric :centimeters :lower 100.0d0 :upper 0.0d0
33f468b7 1194 :position 0.0d0 :max-size 20.0d0))
1195 (v-ruler (make-instance 'v-ruler
704a1de4 1196 :lower 5.0d0 :upper 15.0d0
1197 :position 0.0d0 :max-size 20.0d0)))
33f468b7 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)))
560af5c5 1204
1205
1206;;; Scrolled window
1207
704a1de4 1208(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1209 :default-width 300
1210 :default-height 300)
196fe1e9 1211 (let* ((scrolled-window
1212 (make-instance 'scrolled-window
704a1de4 1213 :parent dialog :border-width 10
1214 :vscrollbar-policy :automatic
196fe1e9 1215 :hscrollbar-policy :automatic))
1216 (table
1217 (make-instance 'table
704a1de4 1218 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1219 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1220 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1221
560af5c5 1222 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1223 (dotimes (i 20)
1224 (dotimes (j 20)
1225 (let ((button
704a1de4 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)))
560af5c5 1230
1231
33f468b7 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
f6ebddea 1253 :parent dialog :border-width 5 :spacing 5
33f468b7 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
560af5c5 1268;;; Shapes
1269
9257d518 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))))
196fe1e9 1276
9257d518 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))
196fe1e9 1282
9257d518 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)
960aa85c 1294 :owner-events t))))
9257d518 1295
1296 (signal-connect window 'button-release-event
1297 #'(lambda (event)
960aa85c 1298 (declare (ignore event))
9257d518 1299 (grab-remove window)
960aa85c 1300 (gdk:pointer-ungrab)))
560af5c5 1301
9257d518 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))))))
560af5c5 1309
9257d518 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)))))
560af5c5 1343
1344
1345
1346;;; Spin buttons
1347
704a1de4 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))))
40a3dac5 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)))))
704a1de4 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)))
560af5c5 1447
704a1de4 1448
c775862e 1449;;; Statusbar
560af5c5 1450
c775862e 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)))
560af5c5 1485
1486
1487;;; Idle test
1488
bdc1babf 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))))
560af5c5 1496
bdc1babf 1497 (make-instance 'v-box
f6ebddea 1498 :parent dialog :border-width 10 :spacing 10
bdc1babf 1499 :child label
1500 :child (make-instance 'frame
1501 :label "Label Container" :border-width 5
1502 :child(make-instance 'v-box
787721b6 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))
bdc1babf 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))))))
560af5c5 1520
bdc1babf 1521 (dialog-add-button dialog "Stop"
1522 #'(lambda ()
1523 (when idle
1524 (idle-remove idle)
1525 (setq idle nil))))))
560af5c5 1526
1527
1528
1529;;; Timeout test
1530
bdc1babf 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))))))
dddfc333 1554
1555
1556;;; Text
1557
1558(define-simple-dialog create-text (dialog "Text" :default-width 400
1559 :default-height 400)
33f468b7 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)))
842e5ffe 1578 (multiple-value-bind (non-zero-p start end)
1579 (text-buffer-get-selection-bounds buffer)
f6ebddea 1580 (declare (ignore non-zero-p))
33f468b7 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
4ea13035 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"))))))
33f468b7 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)
c8ed5c85 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))))))
33f468b7 1669
560af5c5 1670
560af5c5 1671;;; Toggle buttons
1672
704a1de4 1673(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1674 (make-instance 'v-box
f6ebddea 1675 :border-width 10 :spacing 10 :parent dialog
704a1de4 1676 :children (loop
1677 for n from 1 to 3
1678 collect (make-instance 'toggle-button
1679 :label (format nil "Button~D" (1+ n))))))
560af5c5 1680
1681
1682
1683;;; Toolbar test
1684
842e5ffe 1685(defun create-toolbar (window)
787721b6 1686 (make-instance 'toolbar
842e5ffe 1687 :show-tooltips t :show-arrow nil
787721b6 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 ))
560af5c5 1770
842e5ffe 1771(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1772 (container-add window (create-toolbar window)))
1773
560af5c5 1774
9706ddd7 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
560af5c5 1797
1798;;; Tooltips test
1799
bdc1babf 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
f6ebddea 1807 :parent dialog :border-width 10 :spacing 10
bdc1babf 1808 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
812dd869 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")))))
dddfc333 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")
4ea13035 1838 :separator
dddfc333 1839 (:toolitem "Logo"))))
1840
33f468b7 1841(define-toplevel create-ui-manager (window "UI Manager")
4ea13035 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
dddfc333 1893 (ui-manager-add-ui ui *ui-description*)
1894
dddfc333 1895 (make-instance 'v-box
f6ebddea 1896 :parent window
dddfc333 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
ac776134 1904 :label "Type Ctrl+Q to quit"
dddfc333 1905 :xalign 0.5 :yalign 0.5
1906 :width-request 200 :height-request 200))))
560af5c5 1907
1908
1909
560af5c5 1910;;; Main window
1911
f5c99598 1912(defun create-main-window (&optional display)
196fe1e9 1913 (let* ((button-specs
560af5c5 1914 '(("button box" create-button-box)
704a1de4 1915 ("buttons" create-buttons)
1916 ("calendar" create-calendar)
1917 ("check buttons" create-check-buttons)
704a1de4 1918 ("color selection" create-color-selection)
aa9ceddc 1919 ("cursors" create-cursors)
704a1de4 1920 ("dialog" create-dialog)
704a1de4 1921 ("entry" create-entry)
96b68e83 1922 ("enxpander" create-expander)
704a1de4 1923 ("file chooser" create-file-chooser)
3f315085 1924 ("font selection" create-font-selection)
842e5ffe 1925 ("handle box" create-handle-box)
89db7367 1926 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
1927 ("icon view" create-icon-view)
704a1de4 1928 ("image" create-image)
704a1de4 1929 ("labels" create-labels)
1930 ("layout" create-layout)
21f6214a 1931 ("list" create-list)
560af5c5 1932 ("menus" create-menus)
704a1de4 1933;; ("modal window")
1934 ("notebook" create-notebook)
1935 ("panes" create-panes)
977a550d 1936 ("progress bar" create-progress-bar)
704a1de4 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)
33f468b7 1944 ("size group" create-size-group)
9257d518 1945 ("shapes" create-shapes)
704a1de4 1946 ("spinbutton" create-spins)
c775862e 1947 ("statusbar" create-statusbar)
bdc1babf 1948 ("test idle" create-idle-test)
bdc1babf 1949 ("test timeout" create-timeout-test)
dddfc333 1950 ("text" create-text)
704a1de4 1951 ("toggle buttons" create-toggle-buttons)
842e5ffe 1952 ("toolbar" create-toolbar-window)
bdc1babf 1953 ("tooltips" create-tooltips)
89db7367 1954 ("UI manager" create-ui-manager)))
1955
1956 (main-window (make-instance 'window
f5c99598 1957 :display display
89db7367 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
f5c99598 1967 :signal (list 'clicked #'widget-destroy :object main-window))))
560af5c5 1968
977a550d 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)))
812dd869 1973
560af5c5 1974 ;; Main box
704a1de4 1975 (make-instance 'v-box
560af5c5 1976 :parent main-window
704a1de4 1977 :child-args '(:expand nil)
1978 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
bd359292 1979 :child (list (make-instance 'label :label (clg-version)) :fill nil)
c2ef984c 1980 :child (list (make-instance 'label
89db7367 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))))
c2ef984c 1989 ;; The version string in CMUCL is far too long
1990 #+cmu(lisp-implementation-type))
1991 :fill nil)
704a1de4 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)
89db7367 2001 :children (mapcar #'(lambda (spec)
704a1de4 2002 (apply #'create-button spec))
89db7367 2003 button-specs))))
704a1de4 2004 (scrolled-window-add-with-viewport scrolled-window content-box))
560af5c5 2005
704a1de4 2006 (widget-grab-focus close-button)
560af5c5 2007 (widget-show-all main-window)
2008 main-window))
2009
704a1de4 2010(clg-init)
88462189 2011(within-main-loop (create-main-window))
Common Lisp bindings for GTK and friends (local modifications).