mdw@git.distorted.org.uk Git - clg/blame_incremental

... / ...

Commit	Line	Data
	1	;; Common Lisp bindings for GTK+ v2.x
	2	;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
	3	;;
	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:
	11	;;
	12	;; The above copyright notice and this permission notice shall be
	13	;; included in all copies or substantial portions of the Software.
	14	;;
	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.
	22
	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
	29	;; $Id: testgtk.lisp,v 1.31 2005-04-25 18:13:32 espen Exp $
	30
	31	#+sbcl(require :gtk)
	32	#+cmucl(asdf:oos 'asdf:load-op :gtk)
	33
	34	(defpackage "TESTGTK"
	35	(:use "COMMON-LISP" "GTK"))
	36
	37	(in-package "TESTGTK")
	38
	39	(defmacro define-toplevel (name (window title &rest initargs) &body body)
	40	`(let ((,window nil))
	41	(defun ,name ()
	42	(unless ,window
	43	(setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
	44	(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
	45	,@body)
	46
	47	(when ,window
	48	(if (not (widget-visible-p ,window))
	49	(widget-show ,window)
	50	(widget-hide ,window))))))
	51
	52
	53	(defmacro define-dialog (name (dialog title &optional (class 'dialog)
	54	&rest initargs)
	55	&body body)
	56	`(let ((,dialog nil))
	57	(defun ,name ()
	58	(unless ,dialog
	59	(setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
	60	(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
	61	,@body)
	62
	63	(when ,dialog
	64	(if (not (widget-visible-p ,dialog))
	65	(widget-show ,dialog)
	66	(widget-hide ,dialog))))))
	67
	68
	69	(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
	70	`(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
	71	,@body
	72	(dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
	73
	74
	75
	76	;;; Pixmaps used in some of the tests
	77
	78	(defvar gtk-mini-xpm
	79	#("15 20 17 1"
	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
	119	#("16 16 6 1"
	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
	144	#("16 16 4 1"
	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
	167	#("16 16 4 1"
	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
	193	(defun create-bbox-in-frame (class frame-label spacing width height layout)
	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
	199	:child (make-instance 'button :stock "gtk-ok")
	200	:child (make-instance 'button :stock "gtk-cancel")
	201	:child (make-instance 'button :stock "gtk-help"))))
	202
	203	(define-toplevel create-button-box (window "Button Boxes")
	204	(make-instance 'v-box
	205	:parent window :border-width 10 :spacing 10
	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)))))))
	230
	231
	232	;; Buttons
	233
	234	(define-simple-dialog create-buttons (dialog "Buttons")
	235	(let ((table (make-instance 'table
	236	:n-rows 3 :n-columns 3 :homogeneous nil
	237	:row-spacing 5 :column-spacing 5 :border-width 10
	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
	244	(dotimes (column 3)
	245	(dotimes (row 3)
	246	(let ((button (nth (+ (* 3 row) column) buttons))
	247	(button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
	248	(signal-connect button 'clicked
	249	#'(lambda ()
	250	(if (widget-visible-p button+1)
	251	(widget-hide button+1)
	252	(widget-show button+1))))
	253	(table-attach table button column (1+ column) row (1+ row)
	254	:options '(:expand :fill)))))))
	255
	256
	257	;; Calenadar
	258
	259	(define-simple-dialog create-calendar (dialog "Calendar")
	260	(make-instance 'v-box
	261	:parent dialog :border-width 10
	262	:child (make-instance 'calendar)))
	263
	264
	265	;;; Check buttons
	266
	267	(define-simple-dialog create-check-buttons (dialog "Check Buttons")
	268	(make-instance 'v-box
	269	:border-width 10 :spacing 10 :parent dialog
	270	:children (loop
	271	for n from 1 to 3
	272	collect (make-instance 'check-button
	273	:label (format nil "Button~D" n)))))
	274
	275
	276
	277	;;; Color selection
	278
	279	(define-dialog create-color-selection (dialog "Color selection dialog"
	280	'color-selection-dialog
	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)))))
	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))))
	304
	305	(signal-connect dialog :cancel #'widget-destroy :object t)))
	306
	307
	308	;;; Cursors
	309
	310	(defun clamp (n min-val max-val)
	311	(declare (number n min-val max-val))
	312	(max (min n max-val) min-val))
	313
	314	(defun set-cursor (spinner drawing-area label)
	315	(let ((cursor
	316	(glib:int-enum
	317	(logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
	318	'gdk:cursor-type)))
	319	(setf (label-label label) (string-downcase cursor))
	320	(setf (widget-cursor drawing-area) cursor)))
	321
	322	(defun cursor-expose (drawing-area event)
	323	(declare (ignore event))
	324	(multiple-value-bind (width height)
	325	(widget-get-size-allocation drawing-area)
	326	(let* ((window (widget-window drawing-area))
	327	(style (widget-style drawing-area))
	328	(white-gc (style-white-gc style))
	329	(gray-gc (style-bg-gc style :normal))
	330	(black-gc (style-black-gc style)))
	331	(gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
	332	(gdk:draw-rectangle window black-gc t 0 (floor height 2) width
	333	(floor height 2))
	334	(gdk:draw-rectangle window gray-gc t (floor width 3)
	335	(floor height 3) (floor width 3)
	336	(floor height 3))))
	337	t)
	338
	339	(define-simple-dialog create-cursors (dialog "Cursors")
	340	(let ((spinner (make-instance 'spin-button
	341	:adjustment (adjustment-new
	342	0 0
	343	(1- (glib:enum-int :last-cursor 'gdk:cursor-type))
	344	2 10 0)))
	345	(drawing-area (make-instance 'drawing-area
	346	:width-request 80 :height-request 80
	347	:events '(:exposure :button-press)))
	348	(label (make-instance 'label :label "XXX")))
	349
	350	(signal-connect drawing-area 'expose-event #'cursor-expose :object t)
	351
	352	(signal-connect drawing-area 'button-press-event
	353	#'(lambda (event)
	354	(case (gdk:event-button event)
	355	(1 (spin-button-spin spinner :step-forward))
	356	(3 (spin-button-spin spinner :step-backward)))
	357	t))
	358
	359	(signal-connect drawing-area 'scroll-event
	360	#'(lambda (event)
	361	(case (gdk:event-direction event)
	362	(:up (spin-button-spin spinner :step-forward))
	363	(:down (spin-button-spin spinner :step-backward)))
	364	t))
	365
	366	(signal-connect spinner 'changed
	367	#'(lambda ()
	368	(set-cursor spinner drawing-area label)))
	369
	370	(make-instance 'v-box
	371	:parent dialog :border-width 10 :spacing 5
	372	:child (list
	373	(make-instance 'h-box
	374	:border-width 5
	375	:child (list
	376	(make-instance 'label :label "Cursor Value : ")
	377	:expand nil)
	378	:child spinner)
	379	:expand nil)
	380	:child (make-instance 'frame
	381	:label "Cursor Area" :label-xalign 0.5 :border-width 10
	382	:child drawing-area)
	383	:child (list label :expand nil))
	384
	385	(widget-realize drawing-area)
	386	(set-cursor spinner drawing-area label)))
	387
	388
	389	;;; Dialog
	390
	391	(let ((dialog nil))
	392	(defun create-dialog ()
	393	(unless dialog
	394	(setq dialog (make-instance 'dialog
	395	:title "Dialog" :default-width 200
	396	:button "Toggle"
	397	:button (list "gtk-ok" #'widget-destroy :object t)
	398	:signal (list 'destroy
	399	#'(lambda ()
	400	(setq dialog nil)))))
	401
	402	(let ((label (make-instance 'label
	403	:label "Dialog Test" :xpad 10 :ypad 10 :visible t
	404	:parent dialog)))
	405	(signal-connect dialog "Toggle"
	406	#'(lambda ()
	407	(if (widget-visible-p label)
	408	(widget-hide label)
	409	(widget-show label))))))
	410
	411	(if (widget-visible-p dialog)
	412	(widget-hide dialog)
	413	(widget-show dialog))))
	414
	415
	416	;; Entry
	417
	418	(define-simple-dialog create-entry (dialog "Entry")
	419	(let ((main (make-instance 'v-box
	420	:border-width 10 :spacing 10 :parent dialog)))
	421
	422	(let ((entry (make-instance 'entry :text "hello world" :parent main)))
	423	(editable-select-region entry 0 5) ; this has no effect when
	424	; entry is editable
	425	;; (editable-insert-text entry "great " 6)
	426	;; (editable-delete-text entry 6 12)
	427
	428	(let ((combo (make-instance 'combo-box-entry
	429	:parent main
	430	:content '("item0"
	431	"item1 item1"
	432	"item2 item2 item2"
	433	"item3 item3 item3 item3"
	434	"item4 item4 item4 item4 item4"
	435	"item5 item5 item5 item5 item5 item5"
	436	"item6 item6 item6 item6 item6"
	437	"item7 item7 item7 item7"
	438	"item8 item8 item8"
	439	"item9 item9"))))
	440	(with-slots (child) combo
	441	(setf (editable-text child) "hello world")
	442	(editable-select-region child 0)))
	443
	444	(flet ((create-check-button (label slot)
	445	(make-instance 'check-button
	446	:label label :active t :parent main
	447	:signal (list 'toggled
	448	#'(lambda (button)
	449	(setf (slot-value entry slot)
	450	(toggle-button-active-p button)))
	451	:object t))))
	452
	453	(create-check-button "Editable" 'editable)
	454	(create-check-button "Visible" 'visibility)
	455	(create-check-button "Sensitive" 'sensitive)))))
	456
	457
	458	;; Expander
	459
	460	(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
	461	(make-instance 'v-box
	462	:parent dialog :spacing 5 :border-width 5
	463	:child (create-label "Expander demo. Click on the triangle for details.")
	464	:child (make-instance 'expander
	465	:label "Details"
	466	:child (create-label "Details can be shown or hidden."))))
	467
	468
	469	;; File chooser dialog
	470
	471	(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
	472	(file-chooser-add-filter dialog
	473	(make-instance 'file-filter :name "All files" :pattern "*"))
	474	(file-chooser-add-filter dialog
	475	(make-instance 'file-filter :name "Common Lisp source code"
	476	:patterns '(".lisp" ".lsp")))
	477
	478	(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
	479	(dialog-add-button dialog "gtk-ok"
	480	#'(lambda ()
	481	(if (slot-boundp dialog 'filename)
	482	(format t "Selected file: ~A~%" (file-chooser-filename dialog))
	483	(write-line "No files selected"))
	484	(widget-destroy dialog))))
	485
	486
	487	;; Font selection dialog
	488
	489	(define-toplevel create-font-selection (window "Font Button" :resizable nil)
	490	(make-instance 'h-box
	491	:parent window :spacing 8 :border-width 8
	492	:child (make-instance 'label :label "Pick a font")
	493	:child (make-instance 'font-button
	494	:use-font t :title "Font Selection Dialog")))
	495
	496
	497	;;; Icon View
	498
	499	#+gtk2.6
	500	(let ((file-pixbuf nil)
	501	(folder-pixbuf nil))
	502	(defun load-pixbufs ()
	503	(unless file-pixbuf
	504	(handler-case
	505	(setf
	506	file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
	507	folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
	508	(glib:glib-error (condition)
	509	(make-instance 'message-dialog
	510	:message-type :error :visible t
	511	:text "<b>Failed to load an image</b>"
	512	:secondary-text (glib:gerror-message condition)
	513	:signal (list :close #'widget-destroy :object t))
	514	(return-from load-pixbufs nil))))
	515	t)
	516
	517	(defun fill-store (store directory)
	518	(list-store-clear store)
	519	(let ((dir #+cmu(unix:open-dir directory)
	520	#+sbcl(sb-posix:opendir directory)))
	521	(unwind-protect
	522	(loop
	523	as filename = #+cmu(unix:read-dir dir)
	524	#+sbcl(let ((dirent (sb-posix:readdir dir)))
	525	(unless (sb-grovel::foreign-nullp dirent)
	526	(sb-posix:dirent-name dirent)))
	527	while filename
	528	unless (or (equal filename ".") (equal filename ".."))
	529	do (let* ((pathname (format nil "~A~A" directory filename))
	530	(directory-p
	531	#+cmu(eq (unix:unix-file-kind pathname) :directory)
	532	#+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
	533	(list-store-append store
	534	(vector
	535	filename
	536	(if directory-p folder-pixbuf file-pixbuf)
	537	directory-p))))
	538	#+cmu(unix:close-dir dir)
	539	#+sbcl(sb-posix:closedir dir))))
	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
	553	(defun parent-dir (dir)
	554	(let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
	555	(subseq dir 0 end)))
	556
	557	(define-toplevel create-icon-view (window "Icon View demo"
	558	:default-width 650
	559	:default-height 400)
	560	(if (not (load-pixbufs))
	561	(widget-destroy window)
	562	(let* ((directory "/")
	563	(store (make-instance 'list-store
	564	:column-types '(string gdk:pixbuf boolean)
	565	:column-names '(filename pixbuf directory-p)))
	566	(icon-view (make-instance 'icon-view
	567	:model store :selection-mode :multiple
	568	:text-column 'filename :pixbuf-column 'pixbuf))
	569	(up (make-instance 'tool-button
	570	:stock "gtk-go-up" :is-important t :sensitive nil))
	571	(home (make-instance 'tool-button
	572	:stock "gtk-home" :is-important t)))
	573	(tree-sortable-set-sort-func store :default #'sort-func)
	574	(tree-sortable-set-sort-column store :default :ascending)
	575	(fill-store store directory)
	576
	577	(signal-connect icon-view 'item-activated
	578	#'(lambda (path)
	579	(when (tree-model-value store path 'directory-p)
	580	(setq directory
	581	(concatenate 'string directory (tree-model-value store path 'filename) "/"))
	582	(fill-store store directory)
	583	(setf (widget-sensitive-p up) t))))
	584
	585	(signal-connect up 'clicked
	586	#'(lambda ()
	587	(unless (string= directory "/")
	588	(setq directory (parent-dir directory))
	589	(fill-store store directory)
	590	(setf
	591	(widget-sensitive-p home)
	592	(not (string= directory (namestring (truename #p"clg:")))))
	593	(setf (widget-sensitive-p up) (not (string= directory "/"))))))
	594
	595	(signal-connect home 'clicked
	596	#'(lambda ()
	597	(setq directory (namestring (truename #p"clg:")))
	598	(fill-store store directory)
	599	(setf (widget-sensitive-p up) t)
	600	(setf (widget-sensitive-p home) nil)))
	601
	602	(make-instance 'v-box
	603	:parent window
	604	:child (list
	605	(make-instance 'toolbar :child up :child home)
	606	:fill nil :expand nil)
	607	:child (make-instance 'scrolled-window
	608	:shadow-type :etched-in :policy :automatic
	609	:child icon-view))))))
	610
	611
	612	;;; Image
	613
	614	(define-toplevel create-image (window "Image" :resizable nil)
	615	(make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
	616
	617
	618	;;; Labels
	619
	620	(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
	621	(flet ((create-label-in-frame (frame-label label-text &rest args)
	622	(list
	623	(make-instance 'frame
	624	:label frame-label
	625	:child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
	626	:fill nil :expand nil)))
	627	(make-instance 'h-box
	628	:spacing 5 :parent window
	629	:child-args '(:fill nil :expand nil)
	630	:child (make-instance 'v-box
	631	:spacing 5
	632	:child (create-label-in-frame "Normal Label" "This is a Normal label")
	633	:child (create-label-in-frame "Multi-line Label"
	634	"This is a Multi-line label.
	635	Second line
	636	Third line")
	637	:child (create-label-in-frame "Left Justified Label"
	638	"This is a Left-Justified
	639	Multi-line.
	640	Third line"
	641	:justify :left)
	642	:child (create-label-in-frame "Right Justified Label"
	643	"This is a Right-Justified
	644	Multi-line.
	645	Third line"
	646	:justify :right))
	647	:child (make-instance 'v-box
	648	:spacing 5
	649	:child (create-label-in-frame "Line wrapped label"
	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.
	651	It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
	652	:wrap t)
	653
	654	:child (create-label-in-frame "Filled, wrapped label"
	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.
	657	This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
	658	:justify :fill :wrap t)
	659
	660	:child (create-label-in-frame "Underlined label"
	661	(#+cmu glib:latin1-to-unicode #+sbcl identity
	662	"This label is underlined!
	663