~mdw / clg / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
GTK also required when using CLISP
[clg] / examples / testgtk.lisp
CommitLineData
55212af1 1;; Common Lisp bindings for GTK+ v2.x
36550276 2;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net>
0d07716f 3;;
55212af1 4;; Permission is hereby granted, free of charge, to any person obtaining
5;; a copy of this software and associated documentation files (the
6;; "Software"), to deal in the Software without restriction, including
7;; without limitation the rights to use, copy, modify, merge, publish,
8;; distribute, sublicense, and/or sell copies of the Software, and to
9;; permit persons to whom the Software is furnished to do so, subject to
10;; the following conditions:
0d07716f 11;;
55212af1 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
0d07716f 14;;
55212af1 15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
0d07716f 22
55212af1 23;; Parts of this file are direct translations of code from 'testgtk.c'
24;; distributed with the Gtk+ library, and thus covered by the GNU
25;; Lesser General Public License and copyright Peter Mattis, Spencer
26;; Kimball, Josh MacDonald and others.
27
28
b3894ce7 29;; $Id: testgtk.lisp,v 1.36 2006/09/05 13:49:26 espen Exp $
129f5f77 30
31#+sbcl(require :gtk)
36550276 32#+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
0d07716f 33
582a125f 34(defpackage "TESTGTK"
35 (:use "COMMON-LISP" "GTK"))
35ec512c 36
582a125f 37(in-package "TESTGTK")
35ec512c 38
39(defmacro define-toplevel (name (window title &rest initargs) &body body)
40 `(let ((,window nil))
0d07716f 41 (defun ,name ()
35ec512c 42 (unless ,window
6490e9f1 43 (setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
35ec512c 44 (signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
0d07716f 45 ,@body)
46
582a125f 47 (when ,window
48 (if (not (widget-visible-p ,window))
49 (widget-show ,window)
50 (widget-hide ,window))))))
35ec512c 51
0d07716f 52
35ec512c 53(defmacro define-dialog (name (dialog title &optional (class 'dialog)
54 &rest initargs)
55 &body body)
56 `(let ((,dialog nil))
0d07716f 57 (defun ,name ()
35ec512c 58 (unless ,dialog
6490e9f1 59 (setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
35ec512c 60 (signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
61 ,@body)
0d07716f 62
582a125f 63 (when ,dialog
64 (if (not (widget-visible-p ,dialog))
65 (widget-show ,dialog)
66 (widget-hide ,dialog))))))
0d07716f 67
68
35ec512c 69(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
70 `(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
e025589b 71 ,@body
72 (dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
0d07716f 73
74
0d07716f 75
76;;; Pixmaps used in some of the tests
77
78(defvar gtk-mini-xpm
4fb50b71 79 #("15 20 17 1"
0d07716f 80 " c None"
81 ". c #14121F"
82 "+ c #278828"
83 "@ c #9B3334"
84 "# c #284C72"
85 "$ c #24692A"
86 "% c #69282E"
87 "& c #37C539"
88 "* c #1D2F4D"
89 "= c #6D7076"
90 "- c #7D8482"
91 "; c #E24A49"
92 "> c #515357"
93 ", c #9B9C9B"
94 "' c #2FA232"
95 ") c #3CE23D"
96 "! c #3B6CCB"
97 " "
98 " ***> "
99 " >.*!!!* "
100 " ***....#*= "
101 " *!*.!!!**!!# "
102 " .!!#*!#*!!!!# "
103 " @%#!.##.*!!$& "
104 " @;%*!*.#!#')) "
105 " @;;@%!!*$&)'' "
106 " @%.%@%$'&)$+' "
107 " @;...@$'*'*)+ "
108 " @;%..@$+*.')$ "
109 " @;%%;;$+..$)# "
110 " @;%%;@$$$'.$# "
111 " %;@@;;$$+))&* "
112 " %;;;@+$&)&* "
113 " %;;@'))+> "
114 " %;@'&# "
115 " >%$$ "
116 " >= "))
117
118(defvar book-closed-xpm
4fb50b71 119 #("16 16 6 1"
0d07716f 120 " c None s None"
121 ". c black"
122 "X c red"
123 "o c yellow"
124 "O c #808080"
125 "# c white"
126 " "
127 " .. "
128 " ..XX. "
129 " ..XXXXX. "
130 " ..XXXXXXXX. "
131 ".ooXXXXXXXXX. "
132 "..ooXXXXXXXXX. "
133 ".X.ooXXXXXXXXX. "
134 ".XX.ooXXXXXX.. "
135 " .XX.ooXXX..#O "
136 " .XX.oo..##OO. "
137 " .XX..##OO.. "
138 " .X.#OO.. "
139 " ..O.. "
140 " .. "
141 " "))
142
143(defvar mini-page-xpm
4fb50b71 144 #("16 16 4 1"
0d07716f 145 " c None s None"
146 ". c black"
147 "X c white"
148 "o c #808080"
149 " "
150 " ....... "
151 " .XXXXX.. "
152 " .XoooX.X. "
153 " .XXXXX.... "
154 " .XooooXoo.o "
155 " .XXXXXXXX.o "
156 " .XooooooX.o "
157 " .XXXXXXXX.o "
158 " .XooooooX.o "
159 " .XXXXXXXX.o "
160 " .XooooooX.o "
161 " .XXXXXXXX.o "
162 " ..........o "
163 " oooooooooo "
164 " "))
165
166(defvar book-open-xpm
4fb50b71 167 #("16 16 4 1"
0d07716f 168 " c None s None"
169 ". c black"
170 "X c #808080"
171 "o c white"
172 " "
173 " .. "
174 " .Xo. ... "
175 " .Xoo. ..oo. "
176 " .Xooo.Xooo... "
177 " .Xooo.oooo.X. "
178 " .Xooo.Xooo.X. "
179 " .Xooo.oooo.X. "
180 " .Xooo.Xooo.X. "
181 " .Xooo.oooo.X. "
182 " .Xoo.Xoo..X. "
183 " .Xo.o..ooX. "
184 " .X..XXXXX. "
185 " ..X....... "
186 " .. "
187 " "))
188
189
190
191;;; Button box
192
4fb50b71 193(defun create-bbox-in-frame (class frame-label spacing width height layout)
35ec512c 194 (declare (ignore width height))
195 (make-instance 'frame
196 :label frame-label
197 :child (make-instance class
198 :border-width 5 :layout-style layout :spacing spacing
8804934b 199 :child (make-instance 'button :stock "gtk-ok")
200 :child (make-instance 'button :stock "gtk-cancel")
201 :child (make-instance 'button :stock "gtk-help"))))
35ec512c 202
203(define-toplevel create-button-box (window "Button Boxes")
204 (make-instance 'v-box
6490e9f1 205 :parent window :border-width 10 :spacing 10
35ec512c 206 :child (make-instance 'frame
207 :label "Horizontal Button Boxes"
208 :child (make-instance 'v-box
209 :border-width 10 :spacing 10
210 :children (mapcar
211 #'(lambda (args)
212 (apply #'create-bbox-in-frame
213 'h-button-box args))
214 '(("Spread" 40 85 20 :spread)
215 ("Edge" 40 85 20 :edge)
216 ("Start" 40 85 20 :start)
217 ("End" 40 85 20 :end)))))
218 :child (make-instance 'frame
219 :label "Vertical Button Boxes"
220 :child (make-instance 'h-box
221 :border-width 10 :spacing 10
222 :children (mapcar
223 #'(lambda (args)
224 (apply #'create-bbox-in-frame
225 'v-button-box args))
226 '(("Spread" 30 85 20 :spread)
227 ("Edge" 30 85 20 :edge)
228 ("Start" 30 85 20 :start)
229 ("End" 30 85 20 :end)))))))
4fb50b71 230
231
232;; Buttons
233
35ec512c 234(define-simple-dialog create-buttons (dialog "Buttons")
4fb50b71 235 (let ((table (make-instance 'table
35ec512c 236 :n-rows 3 :n-columns 3 :homogeneous nil
4fb50b71 237 :row-spacing 5 :column-spacing 5 :border-width 10
35ec512c 238 :parent dialog))
239 (buttons (loop
240 for n from 1 to 10
241 collect (make-instance 'button
242 :label (format nil "button~D" (1+ n))))))
243
4fb50b71 244 (dotimes (column 3)
245 (dotimes (row 3)
35ec512c 246 (let ((button (nth (+ (* 3 row) column) buttons))
247 (button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
4fb50b71 248 (signal-connect button 'clicked
249 #'(lambda ()
250 (if (widget-visible-p button+1)
251 (widget-hide button+1)
252 (widget-show button+1))))
81f2aa93 253 (table-attach table button column (1+ column) row (1+ row)
6490e9f1 254 :options '(:expand :fill)))))))
0d07716f 255
256
257;; Calenadar
258
35ec512c 259(define-simple-dialog create-calendar (dialog "Calendar")
260 (make-instance 'v-box
6490e9f1 261 :parent dialog :border-width 10
35ec512c 262 :child (make-instance 'calendar)))
0d07716f 263
264
265;;; Check buttons
266
35ec512c 267(define-simple-dialog create-check-buttons (dialog "Check Buttons")
268 (make-instance 'v-box
6490e9f1 269 :border-width 10 :spacing 10 :parent dialog
35ec512c 270 :children (loop
271 for n from 1 to 3
272 collect (make-instance 'check-button
273 :label (format nil "Button~D" n)))))
0d07716f 274
275
276
277;;; Color selection
278
35ec512c 279(define-dialog create-color-selection (dialog "Color selection dialog"
280 'color-selection-dialog
6490e9f1 281 :allow-grow nil :allow-shrink nil
282 :show-children nil)
283 (with-slots (colorsel) dialog
284 (let ((button (make-instance 'check-button :label "Show Opacity")))
285 (dialog-add-action-widget dialog button
286 #'(lambda ()
287 (setf
288 (color-selection-has-opacity-control-p colorsel)
289 (toggle-button-active-p button)))))
290
291 (let ((button (make-instance 'check-button :label "Show Palette")))
292 (dialog-add-action-widget dialog button
293 #'(lambda ()
294 (setf
295 (color-selection-has-palette-p colorsel)
296 (toggle-button-active-p button)))))
35ec512c 297
298 (signal-connect dialog :ok
299 #'(lambda ()
300 (let ((color (color-selection-current-color colorsel)))
301 (format t "Selected color: ~A~%" color)
302 (setf (color-selection-current-color colorsel) color)
303 (widget-hide dialog))))
0d07716f 304
35ec512c 305 (signal-connect dialog :cancel #'widget-destroy :object t)))
0d07716f 306
0d07716f 307
da924068 308;;; Cursors (Note: using the drawing function in Gdk is considered
309;;; deprecated in clg, new code should use Cairo instead)
0d07716f 310
311(defun clamp (n min-val max-val)
312 (declare (number n min-val max-val))
313 (max (min n max-val) min-val))
314
af5eb952 315(defun set-cursor (spinner drawing-area label)
316 (let ((cursor
36550276 317 (gffi:int-enum
af5eb952 318 (logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
319 'gdk:cursor-type)))
320 (setf (label-label label) (string-downcase cursor))
36550276 321 (widget-set-cursor drawing-area cursor)))
af5eb952 322
323(defun cursor-expose (drawing-area event)
324 (declare (ignore event))
325 (multiple-value-bind (width height)
8804934b 326 (widget-get-size-allocation drawing-area)
af5eb952 327 (let* ((window (widget-window drawing-area))
328 (style (widget-style drawing-area))
329 (white-gc (style-white-gc style))
330 (gray-gc (style-bg-gc style :normal))
331 (black-gc (style-black-gc style)))
332 (gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
333 (gdk:draw-rectangle window black-gc t 0 (floor height 2) width
334 (floor height 2))
335 (gdk:draw-rectangle window gray-gc t (floor width 3)
336 (floor height 3) (floor width 3)
337 (floor height 3))))
338 t)
339
340(define-simple-dialog create-cursors (dialog "Cursors")
341 (let ((spinner (make-instance 'spin-button
342 :adjustment (adjustment-new
343 0 0
36550276 344 (1- (gffi:enum-int :last-cursor 'gdk:cursor-type))
af5eb952 345 2 10 0)))
346 (drawing-area (make-instance 'drawing-area
347 :width-request 80 :height-request 80
8f0159a6 348 :events '(:exposure :button-press)))
af5eb952 349 (label (make-instance 'label :label "XXX")))
350
351 (signal-connect drawing-area 'expose-event #'cursor-expose :object t)
352
353 (signal-connect drawing-area 'button-press-event
354 #'(lambda (event)
355 (case (gdk:event-button event)
45314d76 356 (1 (spin-button-spin spinner :step-forward))
357 (3 (spin-button-spin spinner :step-backward)))
af5eb952 358 t))
0d07716f 359
af5eb952 360 (signal-connect drawing-area 'scroll-event
361 #'(lambda (event)
362 (case (gdk:event-direction event)
45314d76 363 (:up (spin-button-spin spinner :step-forward))
364 (:down (spin-button-spin spinner :step-backward)))
af5eb952 365 t))
0d07716f 366
af5eb952 367 (signal-connect spinner 'changed
368 #'(lambda ()
369 (set-cursor spinner drawing-area label)))
0d07716f 370
af5eb952 371 (make-instance 'v-box
6490e9f1 372 :parent dialog :border-width 10 :spacing 5
af5eb952 373 :child (list
374 (make-instance 'h-box
375 :border-width 5
376 :child (list
377 (make-instance 'label :label "Cursor Value : ")
378 :expand nil)
379 :child spinner)
380 :expand nil)
381 :child (make-instance 'frame
af5eb952 382 :label "Cursor Area" :label-xalign 0.5 :border-width 10
383 :child drawing-area)
384 :child (list label :expand nil))
385
386 (widget-realize drawing-area)
387 (set-cursor spinner drawing-area label)))
0d07716f 388
389
390;;; Dialog
391
35ec512c 392(let ((dialog nil))
393 (defun create-dialog ()
394 (unless dialog
395 (setq dialog (make-instance 'dialog
396 :title "Dialog" :default-width 200
397 :button "Toggle"
398 :button (list "gtk-ok" #'widget-destroy :object t)
399 :signal (list 'destroy
400 #'(lambda ()
401 (setq dialog nil)))))
402
403 (let ((label (make-instance 'label
404 :label "Dialog Test" :xpad 10 :ypad 10 :visible t
405 :parent dialog)))
406 (signal-connect dialog "Toggle"
407 #'(lambda ()
408 (if (widget-visible-p label)
409 (widget-hide label)
410 (widget-show label))))))
0d07716f 411
35ec512c 412 (if (widget-visible-p dialog)
413 (widget-hide dialog)
414 (widget-show dialog))))
0d07716f 415
416
417;; Entry
418
35ec512c 419(define-simple-dialog create-entry (dialog "Entry")
420 (let ((main (make-instance 'v-box
421 :border-width 10 :spacing 10 :parent dialog)))
4fb50b71 422
35ec512c 423 (let ((entry (make-instance 'entry :text "hello world" :parent main)))
424 (editable-select-region entry 0 5) ; this has no effect when
425 ; entry is editable
426;; (editable-insert-text entry "great " 6)
427;; (editable-delete-text entry 6 12)
4fb50b71 428
e52cf822 429 (let ((combo (make-instance 'combo-box-entry
35ec512c 430 :parent main
e52cf822 431 :content '("item0"
432 "item1 item1"
433 "item2 item2 item2"
434 "item3 item3 item3 item3"
435 "item4 item4 item4 item4 item4"
436 "item5 item5 item5 item5 item5 item5"
437 "item6 item6 item6 item6 item6"
438 "item7 item7 item7 item7"
439 "item8 item8 item8"
440 "item9 item9"))))
441 (with-slots (child) combo
442 (setf (editable-text child) "hello world")
443 (editable-select-region child 0)))
35ec512c 444
445 (flet ((create-check-button (label slot)
446 (make-instance 'check-button
447 :label label :active t :parent main
448 :signal (list 'toggled
449 #'(lambda (button)
450 (setf (slot-value entry slot)
451 (toggle-button-active-p button)))
452 :object t))))
453
454 (create-check-button "Editable" 'editable)
455 (create-check-button "Visible" 'visibility)
6490e9f1 456 (create-check-button "Sensitive" 'sensitive)))))
0d07716f 457
0d07716f 458
36c95ad8 459;; Expander
460
461(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
462 (make-instance 'v-box
6490e9f1 463 :parent dialog :spacing 5 :border-width 5
36c95ad8 464 :child (create-label "Expander demo. Click on the triangle for details.")
465 :child (make-instance 'expander
466 :label "Details"
467 :child (create-label "Details can be shown or hidden."))))
468
0d07716f 469
35ec512c 470;; File chooser dialog
0d07716f 471
35ec512c 472(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
d5e2ce7c 473 (file-chooser-add-filter dialog
474 (make-instance 'file-filter :name "All files" :pattern "*"))
475 (file-chooser-add-filter dialog
476 (make-instance 'file-filter :name "Common Lisp source code"
477 :patterns '("*.lisp" "*.lsp")))
478
35ec512c 479 (dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
480 (dialog-add-button dialog "gtk-ok"
481 #'(lambda ()
ab652f5f 482 (if (slot-boundp dialog 'filename)
7c1f9a1e 483 (format t "Selected file: ~A~%" (file-chooser-filename dialog))
484 (write-line "No files selected"))
35ec512c 485 (widget-destroy dialog))))
0d07716f 486
487
b9d3ad20 488;; Font selection dialog
489
490(define-toplevel create-font-selection (window "Font Button" :resizable nil)
491 (make-instance 'h-box
492 :parent window :spacing 8 :border-width 8
493 :child (make-instance 'label :label "Pick a font")
494 :child (make-instance 'font-button
495 :use-font t :title "Font Selection Dialog")))
496
0d07716f 497
582a125f 498;;; Icon View
499
36550276 500#?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
582a125f 501(let ((file-pixbuf nil)
502 (folder-pixbuf nil))
503 (defun load-pixbufs ()
504 (unless file-pixbuf
505 (handler-case
506 (setf
36550276 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"))
582a125f 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)
36550276 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))))))
582a125f 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
36550276 553
582a125f 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
36550276 569 :text-column 0 ;'filename
570 :pixbuf-column 1)) ;'pixbuf))
582a125f 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
36550276 583 (concatenate 'string directory (tree-model-value store path 'filename) "/"))
582a125f 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
35ec512c 614;;; Image
0d07716f 615
c1f1a833 616(define-toplevel create-image (window "Image" :resizable nil)
35ec512c 617 (make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
0d07716f 618
619
620;;; Labels
621
35ec512c 622(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
4fb50b71 623 (flet ((create-label-in-frame (frame-label label-text &rest args)
36550276 624 (make-instance 'frame
625 :label frame-label
626 :child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))))
35ec512c 627 (make-instance 'h-box
628 :spacing 5 :parent window
629 :child-args '(:fill nil :expand nil)
630 :child (make-instance 'v-box
36550276 631 :spacing 5 :child-args '(:fill nil :expand nil)
35ec512c 632 :child (create-label-in-frame "Normal Label" "This is a Normal label")
633 :child (create-label-in-frame "Multi-line Label"
0d07716f 634"This is a Multi-line label.
635Second line
4fb50b71 636Third line")
35ec512c 637 :child (create-label-in-frame "Left Justified Label"
0d07716f 638"This is a Left-Justified
639Multi-line.
4fb50b71 640Third line"
35ec512c 641 :justify :left)
642 :child (create-label-in-frame "Right Justified Label"
0d07716f 643"This is a Right-Justified
644Multi-line.
4fb50b71 645Third line"
35ec512c 646 :justify :right))
647 :child (make-instance 'v-box
36550276 648 :spacing 5 :child-args '(:fill nil :expand nil)
35ec512c 649 :child (create-label-in-frame "Line wrapped label"
0d07716f 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.
4fb50b71 651 It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
35ec512c 652 :wrap t)
653
654 :child (create-label-in-frame "Filled, wrapped label"
0d07716f 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.
4fb50b71 657 This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
35ec512c 658 :justify :fill :wrap t)
659
660 :child (create-label-in-frame "Underlined label"
0d07716f 661"This label is underlined!
36550276 662This one is underlined in quite a funky fashion"
35ec512c 663 :justify :left
664 :pattern "_________________________ _ _________ _ _____ _ __ __ ___ ____ _____")))))
0d07716f 665
666
da924068 667;;; Layout (Note: using the drawing function in Gdk is considered
668;;; deprecated in clg, new code should use Cairo instead)
0d07716f 669
af5eb952 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)
35ec512c 689
690(define-toplevel create-layout (window "Layout" :default-width 200
691 :default-height 200)
4fb50b71 692 (let ((layout (make-instance 'layout
693 :parent (make-instance 'scrolled-window :parent window)
8f0159a6 694 :width 1600 :height 128000 :events '(:exposure)
6490e9f1 695 :signal (list 'expose-event #'layout-expose :object t))))
4fb50b71 696
697 (with-slots (hadjustment vadjustment) layout
698 (setf
699 (adjustment-step-increment hadjustment) 10.0
700 (adjustment-step-increment vadjustment) 10.0))
0d07716f 701
702 (dotimes (i 16)
703 (dotimes (j 16)
35ec512c 704 (let ((text (format nil "Button ~D, ~D" i j)))
6490e9f1 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)))))
0d07716f 711
35ec512c 712 (loop
713 for i from 16 below 1280
714 do (let ((text (format nil "Button ~D, ~D" i 0)))
6490e9f1 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))))))
4fb50b71 721
0d07716f 722
723
724;;; List
725
549265c1 726(define-simple-dialog create-list (dialog "List" :default-height 400)
744118a7 727 (let* ((store (make-instance 'list-store
e7020c53 728 :column-types '(string integer boolean)
744118a7 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)))
0d07716f 733
549265c1 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))
744118a7 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
6490e9f1 758 :parent dialog :border-width 10 :spacing 10
744118a7 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))))
0d07716f 815
816
817;; Menus
818
819(defun create-menu (depth tearoff)
820 (unless (zerop depth)
35ec512c 821 (let ((menu (make-instance 'menu)))
0d07716f 822 (when tearoff
35ec512c 823 (let ((menu-item (make-instance 'tearoff-menu-item)))
824 (menu-shell-append menu menu-item)))
0d07716f 825 (let ((group nil))
826 (dotimes (i 5)
35ec512c 827 (let ((menu-item
828 (make-instance 'radio-menu-item
829 :label (format nil "item ~2D - ~D" depth (1+ i)))))
830 (if group
ab652f5f 831 (add-to-radio-group menu-item group)
35ec512c 832 (setq group menu-item))
0d07716f 833 (unless (zerop (mod depth 2))
35ec512c 834 (setf (check-menu-item-active-p menu-item) t))
835 (menu-shell-append menu menu-item)
0d07716f 836 (when (= i 3)
35ec512c 837 (setf (widget-sensitive-p menu-item) nil))
8804934b 838 (let ((submenu (create-menu (1- depth) t)))
839 (when submenu
840 (setf (menu-item-submenu menu-item) submenu))))))
4fb50b71 841 menu)))
0d07716f 842
843
35ec512c 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))))
ab652f5f 848; (window-add-accel-group dialog accel-group)
35ec512c 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
e52cf822 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))))
0d07716f 871
e52cf822 872 (widget-show-all main)))
0d07716f 873
874
875;;; Notebook
876
8804934b 877(defun create-notebook-page (notebook page-num book-closed)
35ec512c 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
36550276 916
35ec512c 917 (let ((label-box (make-instance 'h-box
6490e9f1 918 :show-children t
35ec512c 919 :child-args '(:expand nil)
8804934b 920 :child (make-instance 'image :pixbuf book-closed)
35ec512c 921 :child (make-instance 'label :label title)))
922 (menu-box (make-instance 'h-box
6490e9f1 923 :show-children t
35ec512c 924 :child-args '(:expand nil)
8804934b 925 :child (make-instance 'image :pixbuf book-closed)
35ec512c 926 :child (make-instance 'label :label title))))
927
35ec512c 928 (notebook-append notebook page label-box menu-box))))
0d07716f 929
35ec512c 930(define-simple-dialog create-notebook (dialog "Notebook")
931 (let ((main (make-instance 'v-box :parent dialog)))
8804934b 932 (let ((book-open (gdk:pixbuf-new-from-xpm-data book-open-xpm))
36550276 933 (book-closed (gdk:pixbuf-new-from-xpm-data book-closed-xpm))
934 (notebook (make-instance 'notebook
35ec512c 935 :border-width 10 :tab-pos :top :parent main)))
36550276 936
8804934b 937 (flet ((set-image (page func pixbuf)
938 (setf
939 (image-pixbuf
940 (first (container-children (funcall func notebook page))))
941 pixbuf)))
35ec512c 942 (signal-connect notebook 'switch-page
943 #'(lambda (pointer page)
944 (declare (ignore pointer))
ab652f5f 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)
35ec512c 948 (let ((curpage (notebook-current-page notebook)))
ab652f5f 949 (set-image curpage #'notebook-menu-label book-closed)
950 (set-image curpage #'notebook-tab-label book-closed))))))
8804934b 951 (loop for i from 1 to 5 do (create-notebook-page notebook i book-closed))
35ec512c 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))
e52cf822 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
8804934b 1007 do (create-notebook-page notebook i book-closed))))))
e52cf822 1008 :object t)))
35ec512c 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
36550276 1019 :label "Prev"
35ec512c 1020 :signal (list 'clicked #'notebook-prev-page :object notebook))
1021 :child (make-instance 'button
36550276 1022 :label "Next"
35ec512c 1023 :signal (list 'clicked #'notebook-next-page :object notebook))
1024 :child (make-instance 'button
36550276 1025 :label "Rotate"
35ec512c 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)))
0d07716f 1034
1035
36550276 1036
0d07716f 1037;;; Panes
1038
1039(defun toggle-resize (child)
7c1f9a1e 1040 (setf (paned-child-resize-p child) (not (paned-child-resize-p child))))
0d07716f 1041
1042(defun toggle-shrink (child)
7c1f9a1e 1043 (setf (paned-child-shrink-p child) (not (paned-child-shrink-p child))))
0d07716f 1044
1045(defun create-pane-options (paned frame-label label1 label2)
7c1f9a1e 1046 (let* ((table (make-instance 'table :n-rows 3 :n-columns 2 :homogeneous t)))
81f2aa93 1047 (table-attach table (create-label label1) 0 1 0 1 :options '(:expand :fill))
35ec512c 1048 (let ((check-button (make-instance 'check-button :label "Resize")))
81f2aa93 1049 (table-attach table check-button 0 1 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 1053 (table-attach table check-button 0 1 2 3 :options '(:expand :fill))
7c1f9a1e 1054 (signal-connect check-button 'toggled
1055 #'toggle-shrink :object (paned-child1 paned)))
0d07716f 1056
81f2aa93 1057 (table-attach table (create-label label2) 1 2 0 1 :options '(:expand :fill))
7c1f9a1e 1058 (let ((check-button (make-instance 'check-button :label "Resize" :active t)))
81f2aa93 1059 (table-attach table check-button 1 2 1 2 :options '(:expand :fill))
7c1f9a1e 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)))
81f2aa93 1063 (table-attach table check-button 1 2 2 3 :options '(:expand :fill))
7c1f9a1e 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)))
0d07716f 1067
35ec512c 1068(define-toplevel create-panes (window "Panes")
1069 (let* ((hpaned (make-instance 'h-paned
4fb50b71 1070 :child1 (make-instance 'frame
35ec512c 1071 :width-request 60 :height-request 60
1072 :shadow-type :in
7c1f9a1e 1073 :child (make-instance 'button :label "Hi there"))
35ec512c 1074 :child2 (make-instance 'frame
1075 :width-request 80 :height-request 60
1076 :shadow-type :in)))
1077 (vpaned (make-instance 'v-paned
4fb50b71 1078 :border-width 5
1079 :child1 hpaned
1080 :child2 (make-instance 'frame
35ec512c 1081 :width-request 80 :height-request 60
1082 :shadow-type :in))))
4fb50b71 1083
35ec512c 1084 (make-instance 'v-box
4fb50b71 1085 :parent window
35ec512c 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"))))
0d07716f 1090
1091
0d07716f 1092;;; Progress bar
1093
8804934b 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
6490e9f1 1111 :parent dialog :border-width 10 :spacing 10
8804934b 1112 :child progress
1113 :child activity-mode-button)
1114
1115 (signal-connect dialog 'destroy
1116 #'(lambda () (when timer (timeout-remove timer))))))
0d07716f 1117
1118
1119;;; Radio buttons
1120
35ec512c 1121(define-simple-dialog create-radio-buttons (dialog "Radio buttons")
1122 (make-instance 'v-box
6490e9f1 1123 :parent dialog :border-width 10 :spacing 10
8179fd68 1124 :children (make-radio-group 'radio-button
1125 '((:label "button1") (:label "button2") (:label "button3"))
1126 nil)))
0d07716f 1127
1128
1129;;; Rangle controls
1130
35ec512c 1131(define-simple-dialog create-range-controls (dialog "Range controls")
0d07716f 1132 (let ((adjustment (adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)))
35ec512c 1133 (make-instance 'v-box
6490e9f1 1134 :parent dialog :border-width 10 :spacing 10
35ec512c 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))))
0d07716f 1140
1141
1142;;; Reparent test
1143
35ec512c 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))
8804934b 1147 (label (make-instance 'label :label "Hello World")))
0d07716f 1148
35ec512c 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)))
0d07716f 1159
35ec512c 1160 (box-pack-start (create-frame "Frame 1") label nil t 0)
1161 (create-frame "Frame 2"))
1162 (widget-show-all main)))
0d07716f 1163
1164
1165;;; Rulers
1166
35ec512c 1167(define-toplevel create-rulers (window "Rulers"
1168 :default-width 300 :default-height 300
8f0159a6 1169 :events '(:pointer-motion :pointer-motion-hint))
81f2aa93 1170 (let ((table (make-instance 'table :n-rows 2 :n-columns 2 :parent window))
1171 (h-ruler (make-instance 'h-ruler
35ec512c 1172 :metric :centimeters :lower 100.0d0 :upper 0.0d0
81f2aa93 1173 :position 0.0d0 :max-size 20.0d0))
1174 (v-ruler (make-instance 'v-ruler
35ec512c 1175 :lower 5.0d0 :upper 15.0d0
1176 :position 0.0d0 :max-size 20.0d0)))
81f2aa93 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)))
0d07716f 1183
1184
1185;;; Scrolled window
1186
35ec512c 1187(define-simple-dialog create-scrolled-windows (dialog "Scrolled windows"
1188 :default-width 300
1189 :default-height 300)
4fb50b71 1190 (let* ((scrolled-window
1191 (make-instance 'scrolled-window
35ec512c 1192 :parent dialog :border-width 10
1193 :vscrollbar-policy :automatic
4fb50b71 1194 :hscrollbar-policy :automatic))
1195 (table
1196 (make-instance 'table
35ec512c 1197 :n-rows 20 :n-columns 20 :row-spacing 10 :column-spacing 10
4fb50b71 1198 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
1199 :focus-hadjustment (scrolled-window-hadjustment scrolled-window))))
0d07716f 1200
0d07716f 1201 (scrolled-window-add-with-viewport scrolled-window table)
0d07716f 1202 (dotimes (i 20)
1203 (dotimes (j 20)
1204 (let ((button
35ec512c 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)))
0d07716f 1209
1210
81f2aa93 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
6490e9f1 1232 :parent dialog :border-width 5 :spacing 5
81f2aa93 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
0d07716f 1247;;; Shapes
1248
83bab9b6 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))))
4fb50b71 1255
83bab9b6 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))
4fb50b71 1261
83bab9b6 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)
129f5f77 1273 :owner-events t))))
83bab9b6 1274
1275 (signal-connect window 'button-release-event
1276 #'(lambda (event)
129f5f77 1277 (declare (ignore event))
83bab9b6 1278 (grab-remove window)
129f5f77 1279 (gdk:pointer-ungrab)))
0d07716f 1280
83bab9b6 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))))))
0d07716f 1288
83bab9b6 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)))))
0d07716f 1322
1323
1324
1325;;; Spin buttons
1326
35ec512c 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))))
c1f1a833 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)))))
35ec512c 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)))
0d07716f 1426
35ec512c 1427
5ff67599 1428;;; Statusbar
0d07716f 1429
5ff67599 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)))
0d07716f 1464
1465
1466;;; Idle test
1467
e025589b 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))))
0d07716f 1475
e025589b 1476 (make-instance 'v-box
6490e9f1 1477 :parent dialog :border-width 10 :spacing 10
e025589b 1478 :child label
1479 :child (make-instance 'frame
1480 :label "Label Container" :border-width 5
1481 :child(make-instance 'v-box
8179fd68 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))
e025589b 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))))))
0d07716f 1499
e025589b 1500 (dialog-add-button dialog "Stop"
1501 #'(lambda ()
1502 (when idle
1503 (idle-remove idle)
1504 (setq idle nil))))))
0d07716f 1505
1506
1507
1508;;; Timeout test
1509
e025589b 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))))))
7932cfab 1533
1534
1535;;; Text
1536
1537(define-simple-dialog create-text (dialog "Text" :default-width 400
1538 :default-height 400)
81f2aa93 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)))
ab652f5f 1557 (multiple-value-bind (non-zero-p start end)
1558 (text-buffer-get-selection-bounds buffer)
6490e9f1 1559 (declare (ignore non-zero-p))
81f2aa93 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
d8046c5f 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"))))))
81f2aa93 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)
b3894ce7 1620 (container-add dialog text-view)
1621
1622 (let ((position (make-instance 'label :visible t)))
1623 (flet ((update-position (line column)
1624 (setf
1625 (label-label position)
1626 (format nil "Cursor Position: ~d,~d" (1+ line) column))))
1627 (update-position 0 0)
1628
1629 ;; Callback to display current position when cursor is moved
1630 (signal-connect buffer 'mark-set
1631 #'(lambda (iter mark)
1632 (when (and
1633 (slot-boundp mark 'name)
1634 (string= (text-mark-name mark) "insert"))
1635 (update-position
1636 (text-iter-line iter) (text-iter-line-offset iter)))))
1637
1638 ;; Callback to display current position after the
1639 ;; buffer has been modified
1640 (signal-connect buffer 'changed
1641 #'(lambda ()
1642 (let ((iter (text-buffer-get-iter-at-insert buffer)))
1643 (update-position
1644 (text-iter-line iter) (text-iter-line-offset iter))))
1645 :after t))
1646
1647 (container-add dialog position :expand nil))))))
81f2aa93 1648
0d07716f 1649
0d07716f 1650;;; Toggle buttons
1651
35ec512c 1652(define-simple-dialog create-toggle-buttons (dialog "Toggle Button")
1653 (make-instance 'v-box
6490e9f1 1654 :border-width 10 :spacing 10 :parent dialog
35ec512c 1655 :children (loop
1656 for n from 1 to 3
1657 collect (make-instance 'toggle-button
1658 :label (format nil "Button~D" (1+ n))))))
0d07716f 1659
1660
1661
1662;;; Toolbar test
1663
ab652f5f 1664(defun create-toolbar (window)
8179fd68 1665 (make-instance 'toolbar
ab652f5f 1666 :show-tooltips t :show-arrow nil
8179fd68 1667
1668 ;; Insert a stock item
1669 :child (make-instance 'tool-button
1670 :stock "gtk-quit"
1671 :tip-text "Destroy toolbar"
1672 :tip-private "Toolbar/Quit"
1673 :signal (list 'clicked #'(lambda () (widget-destroy window))))
1674
1675 :child (make-instance 'separator-tool-item)
1676
1677 :child (make-instance 'tool-button
1678 :label "Horizontal" :stock "gtk-go-forward"
1679 :tip-text "Horizontal toolbar layout"
1680 :tip-private "Toolbar/Horizontal"
1681 :signal (list 'clicked
1682 #'(lambda (toolbar)
1683 (setf (toolbar-orientation toolbar) :horizontal))
1684 :object :parent))
1685
1686 :child (make-instance 'tool-button
1687 :label "Vertical" :stock "gtk-go-down"
1688 :tip-text "Vertical toolbar layout"
1689 :tip-private "Toolbar/Vertical"
1690 :signal (list 'clicked
1691 #'(lambda (toolbar)
1692 (setf (toolbar-orientation toolbar) :vertical))
1693 :object :parent))
1694
1695 :child (make-instance 'separator-tool-item)
1696
1697 :children (make-radio-group 'radio-tool-button
1698 '((:label "Icons" :stock "gtk-justify-left"
1699 :tip-text "Only show toolbar icons"
1700 :tip-private "Toolbar/IconsOnly"
1701 :value :icons)
1702 (:label "Both" :stock "gtk-justify-center"
1703 :tip-text "Show toolbar icons and text"
1704 :tip-private "Toolbar/Both"
1705 :value :both :active t)
1706 (:label "Text" :stock "gtk-justify-right"
1707 :tip-text "Show toolbar text"
1708 :tip-private "Toolbar/TextOnly"
1709 :value :text))
1710 (list
1711 #'(lambda (toolbar style)
1712 (setf (toolbar-style toolbar) style))
1713 :object :parent))
1714
1715 :child (make-instance 'separator-tool-item)
1716
1717 :child (make-instance 'tool-item
1718 :child (make-instance 'entry)
1719 :tip-text "This is an unusable GtkEntry"
1720 :tip-private "Hey don't click me!")
1721
1722 :child (make-instance 'separator-tool-item)
1723
1724 :child (make-instance 'tool-button
1725 :label "Enable" :stock "gtk-add"
1726 :tip-text "Enable tooltips"
1727 :tip-private "Toolbar/EnableTooltips"
1728 :signal (list 'clicked
1729 #'(lambda (toolbar)
1730 (setf (toolbar-show-tooltips-p toolbar) t))
1731 :object :parent))
1732
1733 :child (make-instance 'tool-button
1734 :label "Disable" :stock "gtk-remove"
1735 :tip-text "Disable tooltips"
1736 :tip-private "Toolbar/DisableTooltips"
1737 :signal (list 'clicked
1738 #'(lambda (toolbar)
1739 (setf (toolbar-show-tooltips-p toolbar) nil))
1740 :object :parent))
1741
1742;; :child (make-instance 'separator-tool-item)
1743
1744;; :child (make-instance 'tool-button
1745;; :label "GTK" :icon #p"clg:examples;gtk.png"
1746;; :tip-text "GTK+ Logo"
1747;; :tip-private "Toolbar/GTK+")
1748 ))
0d07716f 1749
ab652f5f 1750(define-toplevel create-toolbar-window (window "Toolbar test" :resizable nil)
1751 (container-add window (create-toolbar window)))
1752
0d07716f 1753
09bc2457 1754;;; Handle box
1755
1756(define-toplevel create-handle-box (window "Handle Box Test" :border-width 20)
1757 (make-instance 'v-box
1758 :parent window
1759 :child (create-label "Above")
1760 :child (make-instance 'h-separator)
1761 :child (make-instance 'h-box
1762 :spacing 10
1763 :child (list
1764 (make-instance 'handle-box
1765 :child (create-toolbar window)
1766 :signal (list 'child-attached
1767 #'(lambda (child)
1768 (format t "~A attached~%" child)))
1769 :signal (list 'child-detached
1770 #'(lambda (child)
1771 (format t "~A detached~%" child))))
1772 :expand nil :fill :nil))
1773 :child (make-instance 'h-separator)
1774 :child (create-label "Below")))
1775
0d07716f 1776
1777;;; Tooltips test
1778
e025589b 1779(define-simple-dialog create-tooltips (dialog "Tooltips" :default-width 200)
1780 (let ((tooltips (make-instance 'tooltips)))
1781 (flet ((create-button (label tip-text tip-private)
1782 (let ((button (make-instance 'toggle-button :label label)))
1783 (tooltips-set-tip tooltips button tip-text tip-private)
1784 button)))
1785 (make-instance 'v-box
6490e9f1 1786 :parent dialog :border-width 10 :spacing 10
e025589b 1787 :child (create-button "button1" "This is button 1" "ContextHelp/button/1")
7c1f9a1e 1788 :child (create-button "button2" "This is button 2. This is also has a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly." "ContextHelp/button/2")))))
7932cfab 1789
1790
1791;;; UI Manager
1792
1793(defvar *ui-description*
1794 '((:menubar "MenuBar"
1795 (:menu "FileMenu"
1796 (:menuitem "New")
1797 (:menuitem "Open")
1798 (:menuitem "Save")
1799 (:menuitem "SaveAs")
1800 :separator
1801 (:menuitem "Quit"))
1802 (:menu "PreferencesMenu"
1803 (:menu "ColorMenu"
1804 (:menuitem "Red")
1805 (:menuitem "Green")
1806 (:menuitem "Blue"))
1807 (:menu "ShapeMenu"
1808 (:menuitem "Square")
1809 (:menuitem "Rectangle")
1810 (:menuitem "Oval"))
1811 (:menuitem "Bold"))
1812 (:menu "HelpMenu"
1813 (:menuitem "About")))
1814 (:toolbar "ToolBar"
1815 (:toolitem "Open")
1816 (:toolitem "Quit")
d8046c5f 1817 :separator
7932cfab 1818 (:toolitem "Logo"))))
1819
81f2aa93 1820(define-toplevel create-ui-manager (window "UI Manager")
d8046c5f 1821 (let ((ui (make-instance 'ui-manager)))
1822 (window-add-accel-group window (ui-manager-accel-group ui))
1823 (ui-manager-insert-action-group ui
1824 (make-instance 'action-group :name "Actions"
1825 :action (make-instance 'action :name "FileMenu" :label "_File")
1826 :action (make-instance 'action :name "PreferencesMenu" :label "_Preferences")
1827 :action (make-instance 'action :name "ColorMenu" :label "_Color")
1828 :action (make-instance 'action :name "ShapeMenu" :label "_Shape")
1829 :action (make-instance 'action :name "HelpMenu" :label "_Help")
1830 :action (make-instance 'action
1831 :name "New" :stock-id "gtk-new" :label "_New"
1832 :accelerator "<control>N" :tooltip "Create a new file")
1833 :action (make-instance 'action
1834 :name "Open" :stock-id "gtk-open" :label "_Open"
1835 :accelerator "<control>O" :tooltip "Open a file"
1836 :callback #'create-file-chooser)
1837 :action (make-instance 'action
1838 :name "Save" :stock-id "gtk-save" :label "_Save"
1839 :accelerator "<control>S" :tooltip "Save current file")
1840 :action (make-instance 'action
1841 :name "SaveAs" :stock-id "gtk-save" :label "Save _As..."
1842 :tooltip "Save to a file")
1843 :action (make-instance 'action
1844 :name "Quit" :stock-id "gtk-quit" :label "_Quit"
1845 :accelerator "<control>Q" :tooltip "Quit"
1846 :callback (list #'widget-destroy :object window))
1847 :action (make-instance 'action
1848 :name "About" :label "_About"
1849 :accelerator "<control>A" :tooltip "About")
1850 :action (make-instance 'action
1851 :name "Logo" :stock-id "demo-gtk-logo" :tooltip "GTK+")
1852 :action (make-instance 'toggle-action
1853 :name "Bold" :stock-id "gtk-bold" :label "_Bold"
1854 :accelerator "<control>B" :tooltip "Bold" :active t)
1855 :actions (make-radio-group 'radio-action
1856 '((:name "Red" :value :red :label "_Red"
1857 :accelerator "<control>R" :tooltip "Blood")
1858 (:name "Green" :value :green :label "_Green"
1859 :accelerator "<control>G" :tooltip "Grass" :active t)
1860 (:name "Blue" :value :blue :label "_Blue"
1861 :accelerator "<control>B" :tooltip "Sky"))
1862 #'(lambda (active) (print active)))
1863 :actions (make-radio-group 'radio-action
1864 '((:name "Square" :value :square :label "_Square"
1865 :accelerator "<control>S" :tooltip "Square")
1866 (:name "Rectangle" :value :rectangle :label "_Rectangle"
1867 :accelerator "<control>R" :tooltip "Rectangle")
1868 (:name "Oval" :value :oval :label "_Oval"
1869 :accelerator "<control>O" :tooltip "Egg"))
1870 #'(lambda (active) (print active)))))
1871
7932cfab 1872 (ui-manager-add-ui ui *ui-description*)
1873
7932cfab 1874 (make-instance 'v-box
6490e9f1 1875 :parent window
7932cfab 1876 :child (list
1877 (ui-manager-get-widget ui "/MenuBar")
1878 :expand nil :fill nil)
1879 :child (list
1880 (ui-manager-get-widget ui "/ToolBar")
1881 :expand nil :fill nil)
1882 :child (make-instance 'label
a5d4a9d1 1883 :label "Type Ctrl+Q to quit"
7932cfab 1884 :xalign 0.5 :yalign 0.5
1885 :width-request 200 :height-request 200))))
0d07716f 1886
1887
1888
0d07716f 1889;;; Main window
1890
1891(defun create-main-window ()
4fb50b71 1892 (let* ((button-specs
0d07716f 1893 '(("button box" create-button-box)
35ec512c 1894 ("buttons" create-buttons)
1895 ("calendar" create-calendar)
1896 ("check buttons" create-check-buttons)
35ec512c 1897 ("color selection" create-color-selection)
af5eb952 1898 ("cursors" create-cursors)
35ec512c 1899 ("dialog" create-dialog)
35ec512c 1900 ("entry" create-entry)
36c95ad8 1901 ("enxpander" create-expander)
35ec512c 1902 ("file chooser" create-file-chooser)
b9d3ad20 1903 ("font selection" create-font-selection)
ab652f5f 1904 ("handle box" create-handle-box)
36550276 1905 #?(pkg-config:pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0" :error nil)
1906 ("icon view" create-icon-view)
35ec512c 1907 ("image" create-image)
35ec512c 1908 ("labels" create-labels)
1909 ("layout" create-layout)
549265c1 1910 ("list" create-list)
0d07716f 1911 ("menus" create-menus)
35ec512c 1912;; ("modal window")
1913 ("notebook" create-notebook)
1914 ("panes" create-panes)
8804934b 1915 ("progress bar" create-progress-bar)
35ec512c 1916 ("radio buttons" create-radio-buttons)
1917 ("range controls" create-range-controls)
1918;; ("rc file")
1919 ("reparent" create-reparent)
1920 ("rulers" create-rulers)
1921;; ("saved position")
1922 ("scrolled windows" create-scrolled-windows)
81f2aa93 1923 ("size group" create-size-group)
83bab9b6 1924 ("shapes" create-shapes)
35ec512c 1925 ("spinbutton" create-spins)
5ff67599 1926 ("statusbar" create-statusbar)
e025589b 1927 ("test idle" create-idle-test)
e025589b 1928 ("test timeout" create-timeout-test)
7932cfab 1929 ("text" create-text)
35ec512c 1930 ("toggle buttons" create-toggle-buttons)
ab652f5f 1931 ("toolbar" create-toolbar-window)
e025589b 1932 ("tooltips" create-tooltips)
36550276 1933 ("UI manager" create-ui-manager)))
1934
1935 (main-window (make-instance 'window
1936 :title "testgtk.lisp" :name "main_window"
1937 :default-width 200 :default-height 400
1938 :allow-grow t :allow-shrink nil))
1939 (scrolled-window (make-instance 'scrolled-window
1940 :hscrollbar-policy :automatic
1941 :vscrollbar-policy :automatic
1942 :border-width 10))
1943 (close-button (make-instance 'button
1944 :stock "gtk-close" :can-default t
1945 :signal (list 'clicked #'widget-destroy :object main-window))))
0d07716f 1946
8804934b 1947 (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
1948 (setf
1949 (window-icon main-window)
1950 (gdk:pixbuf-add-alpha icon t 254 254 252)))
7c1f9a1e 1951
0d07716f 1952 ;; Main box
35ec512c 1953 (make-instance 'v-box
0d07716f 1954 :parent main-window
35ec512c 1955 :child-args '(:expand nil)
1956 :child (list (make-instance 'label :label (gtk-version)) :fill nil)
19d91f52 1957 :child (list (make-instance 'label :label (clg-version)) :fill nil)
41aa9108 1958 :child (list (make-instance 'label
36550276 1959 :label #-cmu
1960 (format nil "~A (~A)"
1961 (lisp-implementation-type)
1962 #-clisp
1963 (lisp-implementation-version)
1964 #+clisp
1965 (let ((version (lisp-implementation-version)))
1966 (subseq version 0 (position #\sp version))))
41aa9108 1967 ;; The version string in CMUCL is far too long
1968 #+cmu(lisp-implementation-type))
1969 :fill nil)
35ec512c 1970 :child (list scrolled-window :expand t)
1971 :child (make-instance 'h-separator)
1972 :child (make-instance 'v-box
1973 :homogeneous nil :spacing 10 :border-width 10
1974 :child close-button))
1975
1976 (let ((content-box
1977 (make-instance 'v-box
1978 :focus-vadjustment (scrolled-window-vadjustment scrolled-window)
36550276 1979 :children (mapcar #'(lambda (spec)
35ec512c 1980 (apply #'create-button spec))
36550276 1981 button-specs))))
35ec512c 1982 (scrolled-window-add-with-viewport scrolled-window content-box))
0d07716f 1983
35ec512c 1984 (widget-grab-focus close-button)
0d07716f 1985 (widget-show-all main-window)
1986 main-window))
1987
35ec512c 1988(clg-init)
1989(create-main-window)
36550276 1990
Common Lisp bindings for GTK and friends (local modifications).