chiark / gitweb /
~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Added gffi to the list of used packages
[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
89db7367 29;; $Id: testgtk.lisp,v 1.35 2006-04-26 14:59:50 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"
35 (:use "COMMON-LISP" "GTK"))
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
89db7367 500#?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
58d925ab 501(let ((file-pixbuf nil)
502 (folder-pixbuf nil))
503 (defun load-pixbufs ()
504 (unless file-pixbuf
505 (handler-case
506 (setf
89db7367 507 file-pixbuf (gdk:pixbuf-load #p"/usr/share/icons/gnome/48x48/filesystems/gnome-fs-regular.png")
508 folder-pixbuf (gdk:pixbuf-load #p"/usr/share/icons/gnome/48x48/filesystems/gnome-fs-directory.png"))
58d925ab 509 (glib:glib-error (condition)
510 (make-instance 'message-dialog
511 :message-type :error :visible t
512 :text "<b>Failed to load an image</b>"
513 :secondary-text (glib:gerror-message condition)
514 :signal (list :close #'widget-destroy :object t))
515 (return-from load-pixbufs nil))))
516 t)
517
518 (defun fill-store (store directory)
519 (list-store-clear store)
89db7367 520 (let ((dir-listing
521 (mapcar #'namestring
522 (nconc
523 (directory (format nil "~A*" directory))
524 #+clisp(directory (format nil "~A*/" directory))))))
525 (loop
526 for pathname in dir-listing
527 do (let* ((directory-p
528 (char= #\/ (char pathname (1- (length pathname)))))
529 (filename
530 (subseq pathname
531 (length directory)
532 (if directory-p
533 (1- (length pathname))
534 (length pathname)))))
535 (list-store-append store
536 (vector
537 filename
538 (if directory-p folder-pixbuf file-pixbuf)
539 directory-p))))))
58d925ab 540
541 (defun sort-func (store a b)
542 (let ((a-dir-p (tree-model-value store a 'directory-p))
543 (b-dir-p (tree-model-value store b 'directory-p))
544 (a-name (tree-model-value store a 'filename))
545 (b-name (tree-model-value store b 'filename)))
546 (cond
547 ((and a-dir-p (not b-dir-p)) :before)
548 ((and (not a-dir-p) b-dir-p) :after)
549 ((string< a-name b-name) :before)
550 ((string> a-name b-name) :after)
551 (t :equal))))
552
89db7367 553
58d925ab 554 (defun parent-dir (dir)
555 (let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
556 (subseq dir 0 end)))
557
558 (define-toplevel create-icon-view (window "Icon View demo"
559 :default-width 650
560 :default-height 400)
561 (if (not (load-pixbufs))
562 (widget-destroy window)
563 (let* ((directory "/")
564 (store (make-instance 'list-store
565 :column-types '(string gdk:pixbuf boolean)
566 :column-names '(filename pixbuf directory-p)))
567 (icon-view (make-instance 'icon-view
568 :model store :selection-mode :multiple
89db7367 569 :text-column 0 ;'filename
570 :pixbuf-column 1)) ;'pixbuf))
58d925ab 571 (up (make-instance 'tool-button
572 :stock "gtk-go-up" :is-important t :sensitive nil))
573 (home (make-instance 'tool-button
574 :stock "gtk-home" :is-important t)))
575 (tree-sortable-set-sort-func store :default #'sort-func)
576 (tree-sortable-set-sort-column store :default :ascending)
577 (fill-store store directory)
578
579 (signal-connect icon-view 'item-activated
580 #'(lambda (path)
581 (when (tree-model-value store path 'directory-p)
582 (setq directory
89db7367 583 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
58d925ab 584 (fill-store store directory)
585 (setf (widget-sensitive-p up) t))))
586
587 (signal-connect up 'clicked
588 #'(lambda ()
589 (unless (string= directory "/")
590 (setq directory (parent-dir directory))
591 (fill-store store directory)
592 (setf
593 (widget-sensitive-p home)
594 (not (string= directory (namestring (truename #p"clg:")))))
595 (setf (widget-sensitive-p up) (not (string= directory "/"))))))
596
597 (signal-connect home 'clicked
598 #'(lambda ()
599 (setq directory (namestring (truename #p"clg:")))
600 (fill-store store directory)
601 (setf (widget-sensitive-p up) t)
602 (setf (widget-sensitive-p home) nil)))
603
604 (make-instance 'v-box
605 :parent window
606 :child (list
607 (make-instance 'toolbar :child up :child home)
608 :fill nil :expand nil)
609 :child (make-instance 'scrolled-window
610 :shadow-type :etched-in :policy :automatic
611 :child icon-view))))))
612
613
704a1de4 614;;; Image
560af5c5 615
40a3dac5 616(define-toplevel create-image (window "Image" :resizable nil)
704a1de4 617 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
560af5c5 618
619
620;;; Labels
621
704a1de4 622(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
196fe1e9 623 (flet ((create-label-in-frame (frame-label label-text &rest args)
89db7367 624 (make-instance 'frame
625 :label frame-label
626 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
704a1de4 627 (make-instance 'h-box
628 :spacing 5 :parent window
629 :child-args '(:fill nil :expand nil)
630 :child (make-instance 'v-box
89db7367 631 :spacing 5 :child-args '(:fill nil :expand nil)
704a1de4 632 :child (create-label-in-frame "Normal Label" "This is a Normal label")
633 :child (create-label-in-frame "Multi-line Label"
560af5c5 634"This is a Multi-line label.
635Second line
196fe1e9 636Third line")
704a1de4 637 :child (create-label-in-frame "Left Justified Label"
560af5c5 638"This is a Left-Justified
639Multi-line.
196fe1e9 640Third line"
704a1de4 641 :justify :left)
642 :child (create-label-in-frame "Right Justified Label"
560af5c5 643"This is a Right-Justified
644Multi-line.
196fe1e9 645Third line"
704a1de4 646 :justify :right))
647 :child (make-instance 'v-box
89db7367 648 :spacing 5 :child-args '(:fill nil :expand nil)
704a1de4 649 :child (create-label-in-frame "Line wrapped label"
560af5c5 650"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 651 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
704a1de4 652 :wrap t)
653
654 :child (create-label-in-frame "Filled, wrapped label"
560af5c5 655"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.
656 This is a new paragraph.
196fe1e9 657 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
704a1de4 658 :justify :fill :wrap t)
659
660 :child (create-label-in-frame "Underlined label"
560af5c5 661"This label is underlined!
89db7367 662This one is underlined in quite a funky fashion"
704a1de4 663 :justify :left
664 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
560af5c5 665
666
e898557a 667;;; Layout (Note: using the drawing function in Gdk is considered
668;;; deprecated in clg, new code should use Cairo instead)
560af5c5 669
aa9ceddc 670(defun layout-expose (layout event)
671 (when (eq (gdk:event-window event) (layout-bin-window layout))
672 (with-slots (gdk:x gdk:y gdk:width gdk:height) event
673 (let ((imin (truncate gdk:x 10))
674 (imax (truncate (+ gdk:x gdk:width 9) 10))
675 (jmin (truncate gdk:y 10))
676 (jmax (truncate (+ gdk:y gdk:height 9) 10)))
677
678 (let ((window (layout-bin-window layout))
679 (gc (style-black-gc (widget-style layout))))
680 (loop
681 for i from imin below imax
682 do (loop
683 for j from jmin below jmax
684 unless (zerop (mod (+ i j) 2))
685 do (gdk:draw-rectangle
686 window gc t (* 10 i) (* 10 j)
687 (1+ (mod i 10)) (1+ (mod j 10)))))))))
688 nil)
704a1de4 689
690(define-toplevel create-layout (window "Layout" :default-width 200
691 :default-height 200)
196fe1e9 692 (let ((layout (make-instance 'layout
693 :parent (make-instance 'scrolled-window :parent window)
4280ef98 694 :width 1600 :height 128000 :events '(:exposure)
f6ebddea 695 :signal (list 'expose-event #'layout-expose :object t))))
196fe1e9 696
697 (with-slots (hadjustment vadjustment) layout
698 (setf
699 (adjustment-step-increment hadjustment) 10.0
700 (adjustment-step-increment vadjustment) 10.0))
560af5c5 701
702 (dotimes (i 16)
703 (dotimes (j 16)
704a1de4 704 (let ((text (format nil "Button ~D, ~D" i j)))
f6ebddea 705 (layout-put layout
706 (make-instance (if (not (zerop (mod (+ i j) 2)))
707 'button
708 'label)
709 :label text :visible t)
710 (* j 100) (* i 100)))))
560af5c5 711
704a1de4 712 (loop
713 for i from 16 below 1280
714 do (let ((text (format nil "Button ~D, ~D" i 0)))
f6ebddea 715 (layout-put layout
716 (make-instance (if (not (zerop (mod i 2)))
717 'button
718 'label)
719 :label text :visible t)
720 0 (* i 100))))))
196fe1e9 721
560af5c5 722
723
724;;; List
725
21f6214a 726(define-simple-dialog create-list (dialog "List" :default-height 400)
d975a970 727 (let* ((store (make-instance 'list-store
d01ac6fc 728 :column-types '(string integer boolean)
d975a970 729 :column-names '(:foo :bar :baz)
730 :initial-content '(#("First" 12321 nil)
731 (:foo "Yeah" :baz t))))
732 (tree (make-instance 'tree-view :model store)))
560af5c5 733
21f6214a 734 (loop
735 with iter = (make-instance 'tree-iter)
736 for i from 1 to 1000
737 do (list-store-append store (vector "Test" i (zerop (mod i 3))) iter))
d975a970 738
739 (let ((column (make-instance 'tree-view-column :title "Column 1"))
740 (cell (make-instance 'cell-renderer-text)))
741 (cell-layout-pack column cell :expand t)
742 (cell-layout-add-attribute column cell 'text (column-index store :foo))
743 (tree-view-append-column tree column))
744
745 (let ((column (make-instance 'tree-view-column :title "Column 2"))
746 (cell (make-instance 'cell-renderer-text :background "orange")))
747 (cell-layout-pack column cell :expand t)
748 (cell-layout-add-attribute column cell 'text (column-index store :bar))
749 (tree-view-append-column tree column))
750
751 (let ((column (make-instance 'tree-view-column :title "Column 3"))
752 (cell (make-instance 'cell-renderer-text)))
753 (cell-layout-pack column cell :expand t)
754 (cell-layout-add-attribute column cell 'text (column-index store :baz))
755 (tree-view-append-column tree column))
756
757 (make-instance 'v-box
f6ebddea 758 :parent dialog :border-width 10 :spacing 10
d975a970 759 :child (list
760 (make-instance 'h-box
761 :spacing 10
762 :child (make-instance 'button
763 :label "Remove Selection"
764 :signal (list 'clicked
765 #'(lambda ()
766 (let ((references
767 (mapcar
768 #'(lambda (path)
769 (make-instance 'tree-row-reference :model store :path path))
770 (tree-selection-get-selected-rows
771 (tree-view-selection tree)))))
772 (mapc
773 #'(lambda (reference)
774 (list-store-remove store reference))
775 references))))))
776 :expand nil)
777 :child (list
778 (make-instance 'h-box
779 :spacing 10
780 :child (make-instance 'check-button
781 :label "Show Headers" :active t
782 :signal (list 'toggled
783 #'(lambda (button)
784 (setf
785 (tree-view-headers-visible-p tree)
786 (toggle-button-active-p button)))
787 :object t))
788 :child (make-instance 'check-button
789 :label "Reorderable" :active nil
790 :signal (list 'toggled
791 #'(lambda (button)
792 (setf
793 (tree-view-reorderable-p tree)
794 (toggle-button-active-p button)))
795 :object t))
796 :child (list
797 (make-instance 'h-box
798 :child (make-instance 'label :label "Selection Mode: ")
799 :child (make-instance 'combo-box
800 :content '("Single" "Browse" "Multiple")
801 :active 0
802 :signal (list 'changed
803 #'(lambda (combo-box)
804 (setf
805 (tree-selection-mode
806 (tree-view-selection tree))
807 (svref
808 #(:single :browse :multiple)
809 (combo-box-active combo-box))))
810 :object t)))
811 :expand nil))
812 :expand nil)
813 :child (make-instance 'scrolled-window
814 :child tree :hscrollbar-policy :automatic))))
560af5c5 815
816
817;; Menus
818
819(defun create-menu (depth tearoff)
820 (unless (zerop depth)
704a1de4 821 (let ((menu (make-instance 'menu)))
560af5c5 822 (when tearoff
704a1de4 823 (let ((menu-item (make-instance 'tearoff-menu-item)))
824 (menu-shell-append menu menu-item)))
560af5c5 825 (let ((group nil))
826 (dotimes (i 5)
704a1de4 827 (let ((menu-item
828 (make-instance 'radio-menu-item
829 :label (format nil "item ~2D - ~D" depth (1+ i)))))
830 (if group
842e5ffe 831 (add-to-radio-group menu-item group)
704a1de4 832 (setq group menu-item))
560af5c5 833 (unless (zerop (mod depth 2))
704a1de4 834 (setf (check-menu-item-active-p menu-item) t))
835 (menu-shell-append menu menu-item)
560af5c5 836 (when (= i 3)
704a1de4 837 (setf (widget-sensitive-p menu-item) nil))
977a550d 838 (let ((submenu (create-menu (1- depth) t)))
839 (when submenu
840 (setf (menu-item-submenu menu-item) submenu))))))
196fe1e9 841 menu)))
560af5c5 842
843
704a1de4 844(define-simple-dialog create-menus (dialog "Menus" :default-width 200)
845 (let* ((main (make-instance 'v-box :parent dialog))
846; (accel-group (make-instance 'accel-group))
847 (menubar (make-instance 'menu-bar :parent (list main :expand nil))))
842e5ffe 848; (window-add-accel-group dialog accel-group)
704a1de4 849
850 (let ((menu-item (make-instance 'menu-item
851 :label (format nil "test~%line2"))))
852 (setf (menu-item-submenu menu-item) (create-menu 2 t))
853 (menu-shell-append menubar menu-item))
854
855 (let ((menu-item (make-instance 'menu-item :label "foo")))
856 (setf (menu-item-submenu menu-item) (create-menu 3 t))
857 (menu-shell-append menubar menu-item))
858
859 (let ((menu-item (make-instance 'menu-item :label "bar")))
860 (setf (menu-item-submenu menu-item) (create-menu 4 t))
861 (setf (menu-item-right-justified-p menu-item) t)
862 (menu-shell-append menubar menu-item))
863
613fb570 864 (make-instance 'v-box
865 :spacing 10 :border-width 10 :parent main
866 :child (make-instance 'combo-box
867 :active 3
868 :content (loop
869 for i from 1 to 5
870 collect (format nil "Item ~D" i))))
560af5c5 871
613fb570 872 (widget-show-all main)))
560af5c5 873
874
875;;; Notebook
876
977a550d 877(defun create-notebook-page (notebook page-num book-closed)
704a1de4 878 (let* ((title (format nil "Page ~D" page-num))
879 (page (make-instance 'frame :label title :border-width 10))
880 (v-box (make-instance 'v-box
881 :homogeneous t :border-width 10 :parent page)))
882
883 (make-instance 'h-box
884 :parent (list v-box :fill nil :padding 5) :homogeneous t
885 :child-args '(:padding 5)
886 :child (make-instance 'check-button
887 :label "Fill Tab" :active t
888 :signal (list 'toggled
889 #'(lambda (button)
890 (setf
891 (notebook-child-tab-fill-p page)
892 (toggle-button-active-p button)))
893 :object t))
894 :child (make-instance 'check-button
895 :label "Expand Tab"
896 :signal (list 'toggled
897 #'(lambda (button)
898 (setf
899 (notebook-child-tab-expand-p page)
900 (toggle-button-active-p button)))
901 :object t))
902 :child (make-instance 'check-button
903 :label "Pack end"
904 :signal (list 'toggled
905 #'(lambda (button)
906 (setf
907 (notebook-child-tab-pack page)
908 (if (toggle-button-active-p button)
909 :end
910 :start)))
911 :object t))
912 :child (make-instance 'button
913 :label "Hide page"
914 :signal (list 'clicked #'(lambda () (widget-hide page)))))
915
89db7367 916
704a1de4 917 (let ((label-box (make-instance 'h-box
f6ebddea 918 :show-children t
704a1de4 919 :child-args '(:expand nil)
977a550d 920 :child (make-instance 'image :pixbuf book-closed)
704a1de4 921 :child (make-instance 'label :label title)))
922 (menu-box (make-instance 'h-box
f6ebddea 923 :show-children t
704a1de4 924 :child-args '(:expand nil)
977a550d 925 :child (make-instance 'image :pixbuf book-closed)
704a1de4 926 :child (make-instance 'label :label title))))
927
704a1de4 928 (notebook-append notebook page label-box menu-box))))
560af5c5 929
704a1de4 930(define-simple-dialog create-notebook (dialog "Notebook")
931 (let ((main (make-instance 'v-box :parent dialog)))
977a550d 932 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
89db7367 933 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
934 (notebook (make-instance 'notebook
704a1de4 935 :border-width 10 :tab-pos :top :parent main)))
89db7367 936
977a550d 937 (flet ((set-image (page func pixbuf)
938 (setf
939 (image-pixbuf
940 (first (container-children (funcall func notebook page))))
941 pixbuf)))
704a1de4 942 (signal-connect notebook 'switch-page
943 #'(lambda (pointer page)
944 (declare (ignore pointer))
842e5ffe 945 (set-image page #'notebook-menu-label book-open)
946 (set-image page #'notebook-tab-label book-open)
947 (when (slot-boundp notebook 'current-page)
704a1de4 948 (let ((curpage (notebook-current-page notebook)))
842e5ffe 949 (set-image curpage #'notebook-menu-label book-closed)
950 (set-image curpage #'notebook-tab-label book-closed))))))
977a550d 951 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
704a1de4 952
953 (make-instance 'h-separator :parent (list main :expand nil :padding 10))
954
955 (make-instance 'h-box
956 :spacing 5 :border-width 10
957 :parent (list main :expand nil)
958 :child-args '(:fill nil)
959 :child (make-instance 'check-button
960 :label "Popup menu"
961 :signal (list 'clicked
962 #'(lambda (button)
963 (if (toggle-button-active-p button)
964 (notebook-popup-enable notebook)
965 (notebook-popup-disable notebook)))
966 :object t))
967 :child (make-instance 'check-button
968 :label "Homogeneous tabs"
969 :signal (list 'clicked
970 #'(lambda (button)
971 (setf
972 (notebook-homogeneous-p notebook)
973 (toggle-button-active-p button)))
974 :object t)))
975
976 (make-instance 'h-box
977 :spacing 5 :border-width 10
978 :parent (list main :expand nil)
979 :child-args '(:expand nil)
980 :child (make-instance 'label :label "Notebook Style: ")
981 :child (let ((scrollable-p nil))
613fb570 982 (make-instance 'combo-box
983 :content '("Standard" "No tabs" "Scrollable") :active 0
984 :signal (list 'changed
985 #'(lambda (combo-box)
986 (case (combo-box-active combo-box)
987 (0
988 (setf (notebook-show-tabs-p notebook) t)
989 (when scrollable-p
990 (setq scrollable-p nil)
991 (setf (notebook-scrollable-p notebook) nil)
992 (loop repeat 10
993 do (notebook-remove-page notebook 5))))
994 (1
995 (setf (notebook-show-tabs-p notebook) nil)
996 (when scrollable-p
997 (setq scrollable-p nil)
998 (setf (notebook-scrollable-p notebook) nil)
999 (loop repeat 10
1000 do (notebook-remove-page notebook 5))))
1001 (2
1002 (unless scrollable-p
1003 (setq scrollable-p t)
1004 (setf (notebook-show-tabs-p notebook) t)
1005 (setf (notebook-scrollable-p notebook) t)
1006 (loop for i from 6 to 15
977a550d 1007 do (create-notebook-page notebook i book-closed))))))
613fb570 1008 :object t)))
704a1de4 1009 :child (make-instance 'button
1010 :label "Show all Pages"
1011 :signal (list 'clicked
1012 #'(lambda ()
1013 (map-container nil #'widget-show notebook)))))
1014
1015 (make-instance 'h-box
1016 :spacing 5 :border-width 10
1017 :parent (list main :expand nil)
1018 :child (make-instance 'button
89db7367 1019 :label "Prev"
704a1de4 1020 :signal (list 'clicked #'notebook-prev-page :object notebook))
1021 :child (make-instance 'button
89db7367 1022 :label "Next"
704a1de4 1023 :signal (list 'clicked #'notebook-next-page :object notebook))
1024 :child (make-instance 'button
89db7367 1025 :label "Rotate"
704a1de4 1026 :signal (let ((tab-pos 0))
1027 (list 'clicked
1028 #'(lambda ()
1029 (setq tab-pos (mod (1+ tab-pos) 4))
1030 (setf
1031 (notebook-tab-pos notebook)
1032 (svref #(:top :right :bottom :left) tab-pos))))))))
1033 (widget-show-all main)))
560af5c5 1034
1035
89db7367 1036
560af5c5 1037;;; Panes
1038
1039(defun toggle-resize (child)
812dd869 1040 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
560af5c5 1041
1042(defun toggle-shrink (child)
812dd869 1043 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
560af5c5 1044
1045(defun create-pane-options (paned frame-label label1 label2)
812dd869 1046 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
33f468b7 1047 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
704a1de4 1048 (let ((check-button (make-instance 'check-button :label "Resize")))
33f468b7 1049 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
812dd869 1050 (signal-connect check-button 'toggled
1051 #'toggle-resize :object (paned-child1 paned)))
1052 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
33f468b7 1053 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
812dd869 1054 (signal-connect check-button 'toggled
1055 #'toggle-shrink :object (paned-child1 paned)))
560af5c5 1056
33f468b7 1057 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
812dd869 1058 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
33f468b7 1059 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
812dd869 1060 (signal-connect check-button 'toggled
1061 #'toggle-resize :object (paned-child2 paned)))
1062 (let ((check-button (make-instance 'check-button :label "Shrink" :active t)))
33f468b7 1063 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
812dd869 1064 (signal-connect check-button 'toggled
1065 #'toggle-shrink :object (paned-child2 paned)))
1066 (make-instance 'frame :label frame-label :border-width 4 :child table)))
560af5c5 1067
704a1de4 1068(define-toplevel create-panes (window "Panes")
1069 (let* ((hpaned (make-instance 'h-paned
196fe1e9 1070 :child1 (make-instance 'frame
704a1de4 1071 :width-request 60 :height-request 60
1072 :shadow-type :in
812dd869 1073 :child (make-instance 'button :label "Hi there"))
704a1de4 1074 :child2 (make-instance 'frame
1075 :width-request 80 :height-request 60
1076 :shadow-type :in)))
1077 (vpaned (make-instance 'v-paned
196fe1e9 1078 :border-width 5
1079 :child1 hpaned
1080 :child2 (make-instance 'frame
704a1de4 1081 :width-request 80 :height-request 60
1082 :shadow-type :in))))
196fe1e9 1083
704a1de4 1084 (make-instance 'v-box
196fe1e9 1085 :parent window
704a1de4 1086 :child-args '(:expand nil)
1087 :child (list vpaned :expand t)
1088 :child (create-pane-options hpaned "Horizontal" "Left" "Right")
1089 :child (create-pane-options vpaned "Vertical" "Top" "Bottom"))))
560af5c5 1090
1091
560af5c5 1092;;; Progress bar
1093
977a550d 1094(define-simple-dialog create-progress-bar (dialog "Progress Bar")
1095 (let* ((progress (make-instance 'progress-bar :pulse-step 0.05))
1096 (activity-mode-button (make-instance 'check-button
1097 :label "Activity mode"))
1098 (timer (timeout-add 100
1099 #'(lambda ()
1100 (if (toggle-button-active-p activity-mode-button)
1101 (progress-bar-pulse progress)
1102 (let ((fract (+ (progress-bar-fraction progress) 0.01)))
1103 (setf
1104 (progress-bar-fraction progress)
1105 (if (> fract 1.0)
1106 0.0
1107 fract))))
1108 t))))
1109
1110 (make-instance 'v-box
f6ebddea 1111 :parent dialog :border-width 10 :spacing 10
977a550d 1112 :child progress
1113 :child activity-mode-button)
1114
1115 (signal-connect dialog 'destroy
1116 #'(lambda () (when timer (timeout-remove timer))))))
560af5c5 1117
1118
1119;;; Radio buttons
1120
704a1de4 1121(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1122 (make-instance 'v-box
f6ebddea 1123 :parent dialog :border-width 10 :spacing 10
787721b6 1124 :children (make-radio-group 'radio-button
1125 '((:label "button1") (:label "button2") (:label "button3"))
1126 nil)))
560af5c5 1127
1128
1129;;; Rangle controls
1130
704a1de4 1131(define-simple-dialog create-range-controls (dialog "Range controls")
560af5c5 1132 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
704a1de4 1133 (make-instance 'v-box
f6ebddea 1134 :parent dialog :border-width 10 :spacing 10
704a1de4 1135 :child (make-instance 'h-scale
1136 :width-request 150 :adjustment adjustment :inverted t
1137 :update-policy :delayed :digits 1 :draw-value t)
1138 :child (make-instance 'h-scrollbar
1139 :adjustment adjustment :update-policy :continuous))))
560af5c5 1140
1141
1142;;; Reparent test
1143
704a1de4 1144(define-simple-dialog create-reparent (dialog "Reparent")
1145 (let ((main (make-instance 'h-box
1146 :homogeneous t :spacing 10 :border-width 10 :parent dialog))
977a550d 1147 (label (make-instance 'label :label "Hello World")))
560af5c5 1148
704a1de4 1149 (flet ((create-frame (title)
1150 (let* ((frame (make-instance 'frame :label title :parent main))
1151 (box (make-instance 'v-box
1152 :spacing 5 :border-width 5 :parent frame))
1153 (button (make-instance 'button
1154 :label "switch" :parent (list box :expand nil))))
1155 (signal-connect button 'clicked
1156 #'(lambda ()
1157 (widget-reparent label box)))
1158 box)))
560af5c5 1159
704a1de4 1160 (box-pack-start (create-frame "Frame 1") label nil t 0)
1161 (create-frame "Frame 2"))
1162 (widget-show-all main)))
560af5c5 1163
1164
1165;;; Rulers
1166
704a1de4 1167(define-toplevel create-rulers (window "Rulers"
1168 :default-width 300 :default-height 300
4280ef98 1169 :events '(:pointer-motion :pointer-motion-hint))
33f468b7 1170 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1171 (h-ruler (make-instance 'h-ruler
704a1de4 1172 :metric :centimeters :lower 100.0d0 :upper 0.0d0
33f468b7 1173 :position 0.0d0 :max-size 20.0d0))
1174 (v-ruler (make-instance 'v-ruler
704a1de4 1175 :lower 5.0d0 :upper 15.0d0
1176 :position 0.0d0 :max-size 20.0d0)))
33f468b7 1177 (signal-connect window 'motion-notify-event
1178 #'(lambda (event)
1179 (widget-event h-ruler event)
1180 (widget-event v-ruler event)))
1181 (table-attach table h-ruler 1 2 0 1 :options :fill :x-options :expand)
1182 (table-attach table v-ruler 0 1 1 2 :options :fill :y-options :expand)))
560af5c5 1183
1184
1185;;; Scrolled window
1186
704a1de4 1187(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1188 :default-width 300
1189 :default-height 300)
196fe1e9 1190 (let* ((scrolled-window
1191 (make-instance 'scrolled-window
704a1de4 1192 :parent dialog :border-width 10
1193 :vscrollbar-policy :automatic
196fe1e9 1194 :hscrollbar-policy :automatic))
1195 (table
1196 (make-instance 'table
704a1de4 1197 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
196fe1e9 1198 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1199 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
560af5c5 1200
560af5c5 1201 (scrolled-window-add-with-viewport scrolled-window table)
560af5c5 1202 (dotimes (i 20)
1203 (dotimes (j 20)
1204 (let ((button
704a1de4 1205 (make-instance 'toggle-button
1206 :label (format nil "button (~D,~D)~%" i j))))
1207 (table-attach table button i (1+ i) j (1+ j)))))
1208 (widget-show-all scrolled-window)))
560af5c5 1209
1210
33f468b7 1211;;; Size group
1212
1213(define-simple-dialog create-size-group (dialog "Size Group" :resizable nil)
1214 (let ((size-group (make-instance 'size-group)))
1215 (flet ((create-frame (label rows)
1216 (let ((table (make-instance 'table
1217 :n-rows (length rows) :n-columns 2 :homogeneous nil
1218 :row-spacing 5 :column-spacing 10 :border-width 5)))
1219 (loop
1220 for row in rows
1221 for i from 0
1222 do (table-attach table
1223 (create-label (first row) :xalign 0 :yalign 1)
1224 0 1 i (1+ i) :x-options '(:expand :fill))
1225 (let ((combo (make-instance 'combo-box
1226 :content (rest row) :active 0)))
1227 (size-group-add-widget size-group combo)
1228 (table-attach table combo 1 2 i (1+ i))))
1229 (make-instance 'frame :label label :child table))))
1230
1231 (make-instance 'v-box
f6ebddea 1232 :parent dialog :border-width 5 :spacing 5
33f468b7 1233 :child (create-frame "Color Options"
1234 '(("Foreground" "Red" "Green" "Blue")
1235 ("Background" "Red" "Green" "Blue")))
1236 :child (create-frame "Line Options"
1237 '(("Dashing" "Solid" "Dashed" "Dotted")
1238 ("Line ends" "Square" "Round" "Arrow")))
1239 :child (create-check-button "Enable grouping"
1240 #'(lambda (active)
1241 (setf
1242 (size-group-mode size-group)
1243 (if active :horizontal :none)))
1244 t)))))
1245
1246
560af5c5 1247;;; Shapes
1248
9257d518 1249(defun create-shape-icon (xpm-file x y px py type root-window destroy)
1250 (let ((window
1251 (make-instance 'window
1252 :type type :default-width 100 :default-height 100
1253 :events '(:button-motion :pointer-motion-hint :button-press)
1254 :signal (list 'destroy destroy))))
196fe1e9 1255
9257d518 1256 (widget-realize window)
1257 (multiple-value-bind (source mask) (gdk:pixmap-create xpm-file)
1258 (let ((fixed (make-instance 'fixed :parent window)))
1259 (fixed-put fixed (create-image-widget source mask) px py))
1260 (widget-shape-combine-mask window mask px py))
196fe1e9 1261
9257d518 1262 (let ((x-offset 0)
1263 (y-offset 0))
1264 (declare (fixnum x-offset y-offset))
1265 (signal-connect window 'button-press-event
1266 #'(lambda (event)
1267 (when (typep event 'gdk:button-press-event)
1268 (setq x-offset (truncate (gdk:event-x event)))
1269 (setq y-offset (truncate (gdk:event-y event)))
1270 (grab-add window)
1271 (gdk:pointer-grab (widget-window window)
1272 :events '(:button-release :button-motion :pointer-motion-hint)
960aa85c 1273 :owner-events t))))
9257d518 1274
1275 (signal-connect window 'button-release-event
1276 #'(lambda (event)
960aa85c 1277 (declare (ignore event))
9257d518 1278 (grab-remove window)
960aa85c 1279 (gdk:pointer-ungrab)))
560af5c5 1280
9257d518 1281 (signal-connect window 'motion-notify-event
1282 #'(lambda (event)
1283 (declare (ignore event))
1284 (multiple-value-bind (win xp yp mask)
1285 (gdk:window-get-pointer root-window)
1286 (declare (ignore mask win) (fixnum xp yp))
1287 (window-move window (- xp x-offset) (- yp y-offset))))))
560af5c5 1288
9257d518 1289 (window-move window x y)
1290 (widget-show-all window)
1291 window))
1292
1293
1294(let ((modeller nil)
1295 (sheets nil)
1296 (rings nil))
1297 (defun create-shapes ()
1298 (let ((root-window (gdk:get-root-window)))
1299 (if (not modeller)
1300 (setq
1301 modeller
1302 (create-shape-icon
1303 "clg:examples;Modeller.xpm" 440 140 0 0 :popup root-window
1304 #'(lambda () (setq modeller nil))))
1305 (widget-destroy modeller))
1306
1307 (if (not sheets)
1308 (setq
1309 sheets
1310 (create-shape-icon
1311 "clg:examples;FilesQueue.xpm" 580 170 0 0 :popup root-window
1312 #'(lambda () (setq sheets nil))))
1313 (widget-destroy sheets))
1314
1315 (if (not rings)
1316 (setq
1317 rings
1318 (create-shape-icon
1319 "clg:examples;3DRings.xpm" 460 270 25 25 :toplevel root-window
1320 #'(lambda () (setq rings nil))))
1321 (widget-destroy rings)))))
560af5c5 1322
1323
1324
1325;;; Spin buttons
1326
704a1de4 1327(define-simple-dialog create-spins (dialog "Spin buttons" :has-separator nil)
1328 (let ((main (make-instance 'v-box
1329 :spacing 5 :border-width 10 :parent dialog)))
1330
1331 (flet ((create-date-spinner (label adjustment shadow-type)
1332 (declare (ignore shadow-type))
1333 (make-instance 'v-box
1334 :child-args '(:expand nil)
1335 :child (make-instance 'label
1336 :label label :xalign 0.0 :yalign 0.5)
1337 :child (make-instance 'spin-button
1338 :adjustment adjustment :wrap t))))
40a3dac5 1339 (multiple-value-bind (sec min hour date month year day daylight-p zone)
1340 (get-decoded-time)
1341 (declare (ignore sec min hour day daylight-p zone))
1342 (make-instance 'frame
1343 :label "Not accelerated" :parent main
1344 :child (make-instance 'h-box
1345 :border-width 10
1346 :child-args '(:padding 5)
1347 :child (create-date-spinner "Day : "
1348 (adjustment-new date 1 31 1 5 0) :out)
1349 :child (create-date-spinner "Month : "
1350 (adjustment-new month 1 12 1 5 0) :etched-in)
1351 :child (create-date-spinner "Year : "
1352 (adjustment-new year 0 2100 1 100 0) :in)))))
704a1de4 1353
1354 (let ((spinner1 (make-instance 'spin-button
1355 :adjustment (adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0)
1356 :climb-rate 1.0 :digits 2 :wrap t :width-request 100))
1357 (spinner2 (make-instance 'spin-button
1358 :adjustment (adjustment-new 2.0 1.0 5.0 1.0 1.0 0.0)
1359 :climb-rate 1.0 :wrap t))
1360 (value-label (make-instance 'label :label "0")))
1361 (signal-connect (spin-button-adjustment spinner2) 'value-changed
1362 #'(lambda ()
1363 (setf
1364 (spin-button-digits spinner1)
1365 (floor (spin-button-value spinner2)))))
1366
1367 (make-instance 'frame
1368 :label "Accelerated" :parent main
1369 :child (make-instance 'v-box
1370 :border-width 5
1371 :child (list
1372 (make-instance 'h-box
1373 :child-args '(:padding 5)
1374 :child (make-instance 'v-box
1375 :child (make-instance 'label
1376 :label "Value :"
1377 :xalign 0.0 :yalign 0.5)
1378 :child spinner1)
1379 :child (make-instance 'v-box
1380 :child (make-instance 'label
1381 :label "Digits :"
1382 :xalign 0.0 :yalign 0.5)
1383 :child spinner2))
1384 :expand nil :padding 5)
1385 :child (make-instance 'check-button
1386 :label "Snap to 0.5-ticks" :active t
1387 :signal (list 'clicked
1388 #'(lambda (button)
1389 (setf
1390 (spin-button-snap-to-ticks-p spinner1)
1391 (toggle-button-active-p button)))
1392 :object t))
1393 :child (make-instance 'check-button
1394 :label "Numeric only input mode" :active t
1395 :signal (list 'clicked
1396 #'(lambda (button)
1397 (setf
1398 (spin-button-numeric-p spinner1)
1399 (toggle-button-active-p button)))
1400 :object t))
1401 :child value-label
1402 :child (list
1403 (make-instance 'h-box
1404 :child-args '(:padding 5)
1405 :child (make-instance 'button
1406 :label "Value as Int"
1407 :signal (list 'clicked
1408 #'(lambda ()
1409 (setf
1410 (label-label value-label)
1411 (format nil "~D"
1412 (spin-button-value-as-int
1413 spinner1))))))
1414 :child (make-instance 'button
1415 :label "Value as Float"
1416 :signal (list 'clicked
1417 #'(lambda ()
1418 (setf
1419 (label-label value-label)
1420 (format nil
1421 (format nil "~~,~DF"
1422 (spin-button-digits spinner1))
1423 (spin-button-value spinner1)))))))
1424 :padding 5 :expand nil))))
1425 (widget-show-all main)))
560af5c5 1426
704a1de4 1427
c775862e 1428;;; Statusbar
560af5c5 1429
c775862e 1430(define-toplevel create-statusbar (window "Statusbar")
1431 (let ((statusbar (make-instance 'statusbar :has-resize-grip t))
1432 (close-button (create-button '("close" :can-default t)
1433 #'widget-destroy :object window))
1434 (counter 0))
1435
1436 (signal-connect statusbar 'text-popped
1437 #'(lambda (context-id text)
1438 (declare (ignore context-id))
1439 (format nil "Popped: ~A~%" text)))
1440
1441 (make-instance 'v-box
1442 :parent window
1443 :child (make-instance 'v-box
1444 :border-width 10 :spacing 10
1445 :child (create-button "push something"
1446 #'(lambda ()
1447 (statusbar-push statusbar 1
1448 (format nil "something ~D" (incf counter)))))
1449 :child (create-button "pop"
1450 #'(lambda ()
1451 (statusbar-pop statusbar 1)))
1452 :child (create-button "steal #4"
1453 #'(lambda ()
1454 (statusbar-remove statusbar 1 4)))
1455 :child (create-button "dump stack")
1456 :child (create-button "test contexts"))
1457 :child (list (make-instance 'h-separator) :expand nil)
1458 :child (list
1459 (make-instance 'v-box :border-width 10 :child close-button)
1460 :expand nil)
1461 :child (list statusbar :expand nil))
1462
1463 (widget-grab-focus close-button)))
560af5c5 1464
1465
1466;;; Idle test
1467
bdc1babf 1468(define-simple-dialog create-idle-test (dialog "Idle Test")
1469 (let ((label (make-instance 'label
1470 :label "count: 0" :xpad 10 :ypad 10))
1471 (idle nil)
1472 (count 0))
1473 (signal-connect dialog 'destroy
1474 #'(lambda () (when idle (idle-remove idle))))
560af5c5 1475
bdc1babf 1476 (make-instance 'v-box
f6ebddea 1477 :parent dialog :border-width 10 :spacing 10
bdc1babf 1478 :child label
1479 :child (make-instance 'frame
1480 :label "Label Container" :border-width 5
1481 :child(make-instance 'v-box
787721b6 1482 :children (make-radio-group 'radio-button
1483 '((:label "Resize-Parent" :value :parent :active t)
1484 (:label "Resize-Queue" :value :queue)
1485 (:label "Resize-Immediate" :value :immediate))
bdc1babf 1486 #'(lambda (mode)
1487 (setf
1488 (container-resize-mode (dialog-action-area dialog)) mode))))))
1489
1490 (dialog-add-button dialog "Start"
1491 #'(lambda ()
1492 (unless idle
1493 (setq idle
1494 (idle-add
1495 #'(lambda ()
1496 (incf count)
1497 (setf (label-label label) (format nil "count: ~D" count))
1498 t))))))
560af5c5 1499
bdc1babf 1500 (dialog-add-button dialog "Stop"
1501 #'(lambda ()
1502 (when idle
1503 (idle-remove idle)
1504 (setq idle nil))))))
560af5c5 1505
1506
1507
1508;;; Timeout test
1509
bdc1babf 1510(define-simple-dialog create-timeout-test (dialog "Timeout Test")
1511 (let ((label (make-instance 'label
1512 :label "count: 0" :xpad 10 :ypad 10 :parent dialog :visible t))
1513 (timer nil)
1514 (count 0))
1515 (signal-connect dialog 'destroy
1516 #'(lambda () (when timer (timeout-remove timer))))
1517
1518 (dialog-add-button dialog "Start"
1519 #'(lambda ()
1520 (unless timer
1521 (setq timer
1522 (timeout-add 100
1523 #'(lambda ()
1524 (incf count)
1525 (setf (label-label label) (format nil "count: ~D" count))
1526 t))))))
1527
1528 (dialog-add-button dialog "Stop"
1529 #'(lambda ()
1530 (when timer
1531 (timeout-remove timer)
1532 (setq timer nil))))))
dddfc333 1533
1534
1535;;; Text
1536
1537(define-simple-dialog create-text (dialog "Text" :default-width 400
1538 :default-height 400)
33f468b7 1539 (let* ((text-view (make-instance 'text-view
1540 :border-width 10 :visible t :wrap-mode :word))
1541 (buffer (text-view-buffer text-view))
1542 (active-tags ()))
1543
1544 (text-buffer-create-tag buffer "Bold" :weight :bold)
1545 (text-buffer-create-tag buffer "Italic" :style :italic)
1546 (text-buffer-create-tag buffer "Underline" :underline :single)
1547
1548 (flet ((create-toggle-callback (tag-name)
1549 (let ((tag (text-tag-table-lookup
1550 (text-buffer-tag-table buffer) tag-name)))
1551 #'(lambda (active)
1552 (unless (eq (and (find tag active-tags) t) active)
1553 ;; user activated
1554 (if active
1555 (push tag active-tags)
1556 (setq active-tags (delete tag active-tags)))
842e5ffe 1557 (multiple-value-bind (non-zero-p start end)
1558 (text-buffer-get-selection-bounds buffer)
f6ebddea 1559 (declare (ignore non-zero-p))
33f468b7 1560 (if active
1561 (text-buffer-apply-tag buffer tag start end)
1562 (text-buffer-remove-tag buffer tag start end))))))))
1563
1564 (let* ((actions
1565 (make-instance 'action-group
4ea13035 1566 :action (make-instance 'toggle-action
1567 :name "Bold" :stock-id "gtk-bold" :label "Bold"
1568 :accelerator "<control>B" :tooltip "Bold"
1569 :callback (create-toggle-callback "Bold"))
1570 :action (make-instance 'toggle-action
1571 :name "Italic" :stock-id "gtk-italic" :label "Italic"
1572 :accelerator "<control>I" :tooltip "Italic"
1573 :callback (create-toggle-callback "Italic"))
1574 :action (make-instance 'toggle-action
1575 :name "Underline" :stock-id "gtk-underline"
1576 :label "Underline" :accelerator "<control>U"
1577 :tooltip "Underline"
1578 :callback (create-toggle-callback "Underline"))))
1579 (ui (make-instance 'ui-manager
1580 :action-group actions
1581 :ui '((:toolbar "ToolBar"
1582 (:toolitem "Bold")
1583 (:toolitem "Italic")
1584 (:toolitem "Underline"))))))
33f468b7 1585
1586 ;; Callback to activate/deactivate toolbar buttons when cursor
1587 ;; is moved
1588 (signal-connect buffer 'mark-set
1589 #'(lambda (location mark)
1590 (declare (ignore mark))
1591 (text-tag-table-foreach (text-buffer-tag-table buffer)
1592 #'(lambda (tag)
1593 (let ((active
1594 (or
1595 (and
1596 (text-iter-has-tag-p location tag)
1597 (not (text-iter-begins-tag-p location tag)))
1598 (text-iter-ends-tag-p location tag))))
1599 (unless (eq active (and (find tag active-tags) t))
1600 (if active
1601 (push tag active-tags)
1602 (setq active-tags (delete tag active-tags)))
1603 (setf
1604 (toggle-action-active-p
1605 (action-group-get-action actions (text-tag-name tag)))
1606 active)))))))
1607
1608 ;; Callback to apply active tags when a character is inserted
1609 (signal-connect buffer 'insert-text
1610 #'(lambda (iter &rest args)
1611 (declare (ignore args))
1612 (let ((before (text-buffer-get-iter-at-offset buffer
1613 (1- (text-iter-offset iter)))))
1614 (loop
1615 for tag in active-tags
1616 do (text-buffer-apply-tag buffer tag before iter))))
1617 :after t)
1618
1619 (container-add dialog (ui-manager-get-widget ui "/ToolBar") :expand nil)
1620 (container-add dialog text-view)))))
1621
560af5c5 1622
560af5c5 1623;;; Toggle buttons
1624
704a1de4 1625(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1626 (make-instance 'v-box
f6ebddea 1627 :border-width 10 :spacing 10 :parent dialog
704a1de4 1628 :children (loop
1629 for n from 1 to 3
1630 collect (make-instance 'toggle-button
1631 :label (format nil "Button~D" (1+ n))))))
560af5c5 1632
1633
1634
1635;;; Toolbar test
1636
842e5ffe 1637(defun create-toolbar (window)
787721b6 1638 (make-instance 'toolbar
842e5ffe 1639 :show-tooltips t :show-arrow nil
787721b6 1640
1641 ;; Insert a stock item
1642 :child (make-instance 'tool-button
1643 :stock "gtk-quit"
1644 :tip-text "Destroy toolbar"
1645 :tip-private "Toolbar/Quit"
1646 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1647
1648 :child (make-instance 'separator-tool-item)
1649
1650 :child (make-instance 'tool-button
1651 :label "Horizontal" :stock "gtk-go-forward"
1652 :tip-text "Horizontal toolbar layout"
1653 :tip-private "Toolbar/Horizontal"
1654 :signal (list 'clicked
1655 #'(lambda (toolbar)
1656 (setf (toolbar-orientation toolbar) :horizontal))
1657 :object :parent))
1658
1659 :child (make-instance 'tool-button
1660 :label "Vertical" :stock "gtk-go-down"
1661 :tip-text "Vertical toolbar layout"
1662 :tip-private "Toolbar/Vertical"
1663 :signal (list 'clicked
1664 #'(lambda (toolbar)
1665 (setf (toolbar-orientation toolbar) :vertical))
1666 :object :parent))
1667
1668 :child (make-instance 'separator-tool-item)
1669
1670 :children (make-radio-group 'radio-tool-button
1671 '((:label "Icons" :stock "gtk-justify-left"
1672 :tip-text "Only show toolbar icons"
1673 :tip-private "Toolbar/IconsOnly"
1674 :value :icons)
1675 (:label "Both" :stock "gtk-justify-center"
1676 :tip-text "Show toolbar icons and text"
1677 :tip-private "Toolbar/Both"
1678 :value :both :active t)
1679 (:label "Text" :stock "gtk-justify-right"
1680 :tip-text "Show toolbar text"
1681 :tip-private "Toolbar/TextOnly"
1682 :value :text))
1683 (list
1684 #'(lambda (toolbar style)
1685 (setf (toolbar-style toolbar) style))
1686 :object :parent))
1687
1688 :child (make-instance 'separator-tool-item)
1689
1690 :child (make-instance 'tool-item
1691 :child (make-instance 'entry)
1692 :tip-text "This is an unusable GtkEntry"
1693 :tip-private "Hey don't click me!")
1694
1695 :child (make-instance 'separator-tool-item)
1696
1697 :child (make-instance 'tool-button
1698 :label "Enable" :stock "gtk-add"
1699 :tip-text "Enable tooltips"
1700 :tip-private "Toolbar/EnableTooltips"
1701 :signal (list 'clicked
1702 #'(lambda (toolbar)
1703 (setf (toolbar-show-tooltips-p toolbar) t))
1704 :object :parent))
1705
1706 :child (make-instance 'tool-button
1707 :label "Disable" :stock "gtk-remove"
1708 :tip-text "Disable tooltips"
1709 :tip-private "Toolbar/DisableTooltips"
1710 :signal (list 'clicked
1711 #'(lambda (toolbar)
1712 (setf (toolbar-show-tooltips-p toolbar) nil))
1713 :object :parent))
1714
1715;; :child (make-instance 'separator-tool-item)
1716
1717;; :child (make-instance 'tool-button
1718;; :label "GTK" :icon #p"clg:examples;gtk.png"
1719;; :tip-text "GTK+ Logo"
1720;; :tip-private "Toolbar/GTK+")
1721 ))
560af5c5 1722
842e5ffe 1723(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1724 (container-add window (create-toolbar window)))
1725
560af5c5 1726
9706ddd7 1727;;; Handle box
1728
1729(define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1730 (make-instance 'v-box
1731 :parent window
1732 :child (create-label "Above")
1733 :child (make-instance 'h-separator)
1734 :child (make-instance 'h-box
1735 :spacing 10
1736 :child (list
1737 (make-instance 'handle-box
1738 :child (create-toolbar window)
1739 :signal (list 'child-attached
1740 #'(lambda (child)
1741 (format t "~A attached~%" child)))
1742 :signal (list 'child-detached
1743 #'(lambda (child)
1744 (format t "~A detached~%" child))))
1745 :expand nil :fill :nil))
1746 :child (make-instance 'h-separator)
1747 :child (create-label "Below")))
1748
560af5c5 1749
1750;;; Tooltips test
1751
bdc1babf 1752(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1753 (let ((tooltips (make-instance 'tooltips)))
1754 (flet ((create-button (label tip-text tip-private)
1755 (let ((button (make-instance 'toggle-button :label label)))
1756 (tooltips-set-tip tooltips button tip-text tip-private)
1757 button)))
1758 (make-instance 'v-box
f6ebddea 1759 :parent dialog :border-width 10 :spacing 10
bdc1babf 1760 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
812dd869 1761 :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 1762
1763
1764;;; UI Manager
1765
1766(defvar *ui-description*
1767 '((:menubar "MenuBar"
1768 (:menu "FileMenu"
1769 (:menuitem "New")
1770 (:menuitem "Open")
1771 (:menuitem "Save")
1772 (:menuitem "SaveAs")
1773 :separator
1774 (:menuitem "Quit"))
1775 (:menu "PreferencesMenu"
1776 (:menu "ColorMenu"
1777 (:menuitem "Red")
1778 (:menuitem "Green")
1779 (:menuitem "Blue"))
1780 (:menu "ShapeMenu"
1781 (:menuitem "Square")
1782 (:menuitem "Rectangle")
1783 (:menuitem "Oval"))
1784 (:menuitem "Bold"))
1785 (:menu "HelpMenu"
1786 (:menuitem "About")))
1787 (:toolbar "ToolBar"
1788 (:toolitem "Open")
1789 (:toolitem "Quit")
4ea13035 1790 :separator
dddfc333 1791 (:toolitem "Logo"))))
1792
33f468b7 1793(define-toplevel create-ui-manager (window "UI Manager")
4ea13035 1794 (let ((ui (make-instance 'ui-manager)))
1795 (window-add-accel-group window (ui-manager-accel-group ui))
1796 (ui-manager-insert-action-group ui
1797 (make-instance 'action-group :name "Actions"
1798 :action (make-instance 'action :name "FileMenu" :label "_File")
1799 :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
1800 :action (make-instance 'action :name "ColorMenu" :label "_Color")
1801 :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
1802 :action (make-instance 'action :name "HelpMenu" :label "_Help")
1803 :action (make-instance 'action
1804 :name "New" :stock-id "gtk-new" :label "_New"
1805 :accelerator "<control>N" :tooltip "Create a new file")
1806 :action (make-instance 'action
1807 :name "Open" :stock-id "gtk-open" :label "_Open"
1808 :accelerator "<control>O" :tooltip "Open a file"
1809 :callback #'create-file-chooser)
1810 :action (make-instance 'action
1811 :name "Save" :stock-id "gtk-save" :label "_Save"
1812 :accelerator "<control>S" :tooltip "Save current file")
1813 :action (make-instance 'action
1814 :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
1815 :tooltip "Save to a file")
1816 :action (make-instance 'action
1817 :name "Quit" :stock-id "gtk-quit" :label "_Quit"
1818 :accelerator "<control>Q" :tooltip "Quit"
1819 :callback (list #'widget-destroy :object window))
1820 :action (make-instance 'action
1821 :name "About" :label "_About"
1822 :accelerator "<control>A" :tooltip "About")
1823 :action (make-instance 'action
1824 :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
1825 :action (make-instance 'toggle-action
1826 :name "Bold" :stock-id "gtk-bold" :label "_Bold"
1827 :accelerator "<control>B" :tooltip "Bold" :active t)
1828 :actions (make-radio-group 'radio-action
1829 '((:name "Red" :value :red :label "_Red"
1830 :accelerator "<control>R" :tooltip "Blood")
1831 (:name "Green" :value :green :label "_Green"
1832 :accelerator "<control>G" :tooltip "Grass" :active t)
1833 (:name "Blue" :value :blue :label "_Blue"
1834 :accelerator "<control>B" :tooltip "Sky"))
1835 #'(lambda (active) (print active)))
1836 :actions (make-radio-group 'radio-action
1837 '((:name "Square" :value :square :label "_Square"
1838 :accelerator "<control>S" :tooltip "Square")
1839 (:name "Rectangle" :value :rectangle :label "_Rectangle"
1840 :accelerator "<control>R" :tooltip "Rectangle")
1841 (:name "Oval" :value :oval :label "_Oval"
1842 :accelerator "<control>O" :tooltip "Egg"))
1843 #'(lambda (active) (print active)))))
1844
dddfc333 1845 (ui-manager-add-ui ui *ui-description*)
1846
dddfc333 1847 (make-instance 'v-box
f6ebddea 1848 :parent window
dddfc333 1849 :child (list
1850 (ui-manager-get-widget ui "/MenuBar")
1851 :expand nil :fill nil)
1852 :child (list
1853 (ui-manager-get-widget ui "/ToolBar")
1854 :expand nil :fill nil)
1855 :child (make-instance 'label
ac776134 1856 :label "Type Ctrl+Q to quit"
dddfc333 1857 :xalign 0.5 :yalign 0.5
1858 :width-request 200 :height-request 200))))
560af5c5 1859
1860
1861
560af5c5 1862;;; Main window
1863
1864(defun create-main-window ()
196fe1e9 1865 (let* ((button-specs
560af5c5 1866 '(("button box" create-button-box)
704a1de4 1867 ("buttons" create-buttons)
1868 ("calendar" create-calendar)
1869 ("check buttons" create-check-buttons)
704a1de4 1870 ("color selection" create-color-selection)
aa9ceddc 1871 ("cursors" create-cursors)
704a1de4 1872 ("dialog" create-dialog)
704a1de4 1873 ("entry" create-entry)
96b68e83 1874 ("enxpander" create-expander)
704a1de4 1875 ("file chooser" create-file-chooser)
3f315085 1876 ("font selection" create-font-selection)
842e5ffe 1877 ("handle box" create-handle-box)
89db7367 1878 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
1879 ("icon view" create-icon-view)
704a1de4 1880 ("image" create-image)
704a1de4 1881 ("labels" create-labels)
1882 ("layout" create-layout)
21f6214a 1883 ("list" create-list)
560af5c5 1884 ("menus" create-menus)
704a1de4 1885;; ("modal window")
1886 ("notebook" create-notebook)
1887 ("panes" create-panes)
977a550d 1888 ("progress bar" create-progress-bar)
704a1de4 1889 ("radio buttons" create-radio-buttons)
1890 ("range controls" create-range-controls)
1891;; ("rc file")
1892 ("reparent" create-reparent)
1893 ("rulers" create-rulers)
1894;; ("saved position")
1895 ("scrolled windows" create-scrolled-windows)
33f468b7 1896 ("size group" create-size-group)
9257d518 1897 ("shapes" create-shapes)
704a1de4 1898 ("spinbutton" create-spins)
c775862e 1899 ("statusbar" create-statusbar)
bdc1babf 1900 ("test idle" create-idle-test)
bdc1babf 1901 ("test timeout" create-timeout-test)
dddfc333 1902 ("text" create-text)
704a1de4 1903 ("toggle buttons" create-toggle-buttons)
842e5ffe 1904 ("toolbar" create-toolbar-window)
bdc1babf 1905 ("tooltips" create-tooltips)
89db7367 1906 ("UI manager" create-ui-manager)))
1907
1908 (main-window (make-instance 'window
1909 :title "testgtk.lisp" :name "main_window"
1910 :default-width 200 :default-height 400
1911 :allow-grow t :allow-shrink nil))
1912 (scrolled-window (make-instance 'scrolled-window
1913 :hscrollbar-policy :automatic
1914 :vscrollbar-policy :automatic
1915 :border-width 10))
1916 (close-button (make-instance 'button
1917 :stock "gtk-close" :can-default t
1918 :signal (list 'clicked #'widget-destroy :object main-window))))
560af5c5 1919
977a550d 1920 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1921 (setf
1922 (window-icon main-window)
1923 (gdk:pixbuf-add-alpha icon t 254 254 252)))
812dd869 1924
560af5c5 1925 ;; Main box
704a1de4 1926 (make-instance 'v-box
560af5c5 1927 :parent main-window
704a1de4 1928 :child-args '(:expand nil)
1929 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
bd359292 1930 :child (list (make-instance 'label :label (clg-version)) :fill nil)
c2ef984c 1931 :child (list (make-instance 'label
89db7367 1932 :label #-cmu
1933 (format nil "~A (~A)"
1934 (lisp-implementation-type)
1935 #-clisp
1936 (lisp-implementation-version)
1937 #+clisp
1938 (let ((version (lisp-implementation-version)))
1939 (subseq version 0 (position #\sp version))))
c2ef984c 1940 ;; The version string in CMUCL is far too long
1941 #+cmu(lisp-implementation-type))
1942 :fill nil)
704a1de4 1943 :child (list scrolled-window :expand t)
1944 :child (make-instance 'h-separator)
1945 :child (make-instance 'v-box
1946 :homogeneous nil :spacing 10 :border-width 10
1947 :child close-button))
1948
1949 (let ((content-box
1950 (make-instance 'v-box
1951 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
89db7367 1952 :children (mapcar #'(lambda (spec)
704a1de4 1953 (apply #'create-button spec))
89db7367 1954 button-specs))))
704a1de4 1955 (scrolled-window-add-with-viewport scrolled-window content-box))
560af5c5 1956
704a1de4 1957 (widget-grab-focus close-button)
560af5c5 1958 (widget-show-all main-window)
1959 main-window))
1960
704a1de4 1961(clg-init)
1962(create-main-window)
89db7367 1963
Common Lisp bindings for GTK and friends (local modifications).