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.33 2006-02-13 16:05:29 espen Exp $
	30
	31	#+sbcl(require :gtk)
	32	#+sbcl(require :sb-posix)
	33	#+cmu(asdf:oos 'asdf:load-op :gtk)
	34
	35	(defpackage "TESTGTK"
	36	(:use "COMMON-LISP" "GTK"))
	37
	38	(in-package "TESTGTK")
	39
	40	(defmacro define-toplevel (name (window title &rest initargs) &body body)
	41	`(let ((,window nil))
	42	(defun ,name ()
	43	(unless ,window
	44	(setq ,window (make-instance 'window :title ,title ,@initargs :show-children t))
	45	(signal-connect ,window 'destroy #'(lambda () (setq ,window nil)))
	46	,@body)
	47
	48	(when ,window
	49	(if (not (widget-visible-p ,window))
	50	(widget-show ,window)
	51	(widget-hide ,window))))))
	52
	53
	54	(defmacro define-dialog (name (dialog title &optional (class 'dialog)
	55	&rest initargs)
	56	&body body)
	57	`(let ((,dialog nil))
	58	(defun ,name ()
	59	(unless ,dialog
	60	(setq ,dialog (make-instance ,class :title ,title ,@initargs :show-children t))
	61	(signal-connect ,dialog 'destroy #'(lambda () (setq ,dialog nil)))
	62	,@body)
	63
	64	(when ,dialog
	65	(if (not (widget-visible-p ,dialog))
	66	(widget-show ,dialog)
	67	(widget-hide ,dialog))))))
	68
	69
	70	(defmacro define-simple-dialog (name (dialog title &rest initargs) &body body)
	71	`(define-dialog ,name (,dialog ,title 'dialog ,@initargs)
	72	,@body
	73	(dialog-add-button ,dialog "gtk-close" #'widget-destroy :object t)))
	74
	75
	76
	77	;;; Pixmaps used in some of the tests
	78
	79	(defvar gtk-mini-xpm
	80	#("15 20 17 1"
	81	" c None"
	82	". c #14121F"
	83	"+ c #278828"
	84	"@ c #9B3334"
	85	"# c #284C72"
	86	"$ c #24692A"
	87	"% c #69282E"
	88	"& c #37C539"
	89	"* c #1D2F4D"
	90	"= c #6D7076"
	91	"- c #7D8482"
	92	"; c #E24A49"
	93	"> c #515357"
	94	", c #9B9C9B"
	95	"' c #2FA232"
	96	") c #3CE23D"
	97	"! c #3B6CCB"
	98	" "
	99	" ***> "
	100	" >.!!! "
	101	" **....#= "
	102	" !.!!!**!!# "
	103	" .!!#!#!!!!# "
	104	" @%#!.##.*!!$& "
	105	" @;%!.#!#')) "
	106	" @;;@%!!*$&)'' "
	107	" @%.%@%$'&)$+' "
	108	" @;...@$'')+ "
	109	" @;%..@$+*.')$ "
	110	" @;%%;;$+..$)# "
	111	" @;%%;@$$$'.$# "
	112	" %;@@;;$$+))&* "
	113	" %;;;@+$&)&* "
	114	" %;;@'))+> "
	115	" %;@'&# "
	116	" >%$$ "
	117	" >= "))
	118
	119	(defvar book-closed-xpm
	120	#("16 16 6 1"
	121	" c None s None"
	122	". c black"
	123	"X c red"
	124	"o c yellow"
	125	"O c #808080"
	126	"# c white"
	127	" "
	128	" .. "
	129	" ..XX. "
	130	" ..XXXXX. "
	131	" ..XXXXXXXX. "
	132	".ooXXXXXXXXX. "
	133	"..ooXXXXXXXXX. "
	134	".X.ooXXXXXXXXX. "
	135	".XX.ooXXXXXX.. "
	136	" .XX.ooXXX..#O "
	137	" .XX.oo..##OO. "
	138	" .XX..##OO.. "
	139	" .X.#OO.. "
	140	" ..O.. "
	141	" .. "
	142	" "))
	143
	144	(defvar mini-page-xpm
	145	#("16 16 4 1"
	146	" c None s None"
	147	". c black"
	148	"X c white"
	149	"o c #808080"
	150	" "
	151	" ....... "
	152	" .XXXXX.. "
	153	" .XoooX.X. "
	154	" .XXXXX.... "
	155	" .XooooXoo.o "
	156	" .XXXXXXXX.o "
	157	" .XooooooX.o "
	158	" .XXXXXXXX.o "
	159	" .XooooooX.o "
	160	" .XXXXXXXX.o "
	161	" .XooooooX.o "
	162	" .XXXXXXXX.o "
	163	" ..........o "
	164	" oooooooooo "
	165	" "))
	166
	167	(defvar book-open-xpm
	168	#("16 16 4 1"
	169	" c None s None"
	170	". c black"
	171	"X c #808080"
	172	"o c white"
	173	" "
	174	" .. "
	175	" .Xo. ... "
	176	" .Xoo. ..oo. "
	177	" .Xooo.Xooo... "
	178	" .Xooo.oooo.X. "
	179	" .Xooo.Xooo.X. "
	180	" .Xooo.oooo.X. "
	181	" .Xooo.Xooo.X. "
	182	" .Xooo.oooo.X. "
	183	" .Xoo.Xoo..X. "
	184	" .Xo.o..ooX. "
	185	" .X..XXXXX. "
	186	" ..X....... "
	187	" .. "
	188	" "))
	189
	190
	191
	192	;;; Button box
	193
	194	(defun create-bbox-in-frame (class frame-label spacing width height layout)
	195	(declare (ignore width height))
	196	(make-instance 'frame
	197	:label frame-label
	198	:child (make-instance class
	199	:border-width 5 :layout-style layout :spacing spacing
	200	:child (make-instance 'button :stock "gtk-ok")
	201	:child (make-instance 'button :stock "gtk-cancel")
	202	:child (make-instance 'button :stock "gtk-help"))))
	203
	204	(define-toplevel create-button-box (window "Button Boxes")
	205	(make-instance 'v-box
	206	:parent window :border-width 10 :spacing 10
	207	:child (make-instance 'frame
	208	:label "Horizontal Button Boxes"
	209	:child (make-instance 'v-box
	210	:border-width 10 :spacing 10
	211	:children (mapcar
	212	#'(lambda (args)
	213	(apply #'create-bbox-in-frame
	214	'h-button-box args))
	215	'(("Spread" 40 85 20 :spread)
	216	("Edge" 40 85 20 :edge)
	217	("Start" 40 85 20 :start)
	218	("End" 40 85 20 :end)))))
	219	:child (make-instance 'frame
	220	:label "Vertical Button Boxes"
	221	:child (make-instance 'h-box
	222	:border-width 10 :spacing 10
	223	:children (mapcar
	224	#'(lambda (args)
	225	(apply #'create-bbox-in-frame
	226	'v-button-box args))
	227	'(("Spread" 30 85 20 :spread)
	228	("Edge" 30 85 20 :edge)
	229	("Start" 30 85 20 :start)
	230	("End" 30 85 20 :end)))))))
	231
	232
	233	;; Buttons
	234
	235	(define-simple-dialog create-buttons (dialog "Buttons")
	236	(let ((table (make-instance 'table
	237	:n-rows 3 :n-columns 3 :homogeneous nil
	238	:row-spacing 5 :column-spacing 5 :border-width 10
	239	:parent dialog))
	240	(buttons (loop
	241	for n from 1 to 10
	242	collect (make-instance 'button
	243	:label (format nil "button~D" (1+ n))))))
	244
	245	(dotimes (column 3)
	246	(dotimes (row 3)
	247	(let ((button (nth (+ (* 3 row) column) buttons))
	248	(button+1 (nth (mod (+ (* 3 row) column 1) 9) buttons)))
	249	(signal-connect button 'clicked
	250	#'(lambda ()
	251	(if (widget-visible-p button+1)
	252	(widget-hide button+1)
	253	(widget-show button+1))))
	254	(table-attach table button column (1+ column) row (1+ row)
	255	:options '(:expand :fill)))))))
	256
	257
	258	;; Calenadar
	259
	260	(define-simple-dialog create-calendar (dialog "Calendar")
	261	(make-instance 'v-box
	262	:parent dialog :border-width 10
	263	:child (make-instance 'calendar)))
	264
	265
	266	;;; Check buttons
	267
	268	(define-simple-dialog create-check-buttons (dialog "Check Buttons")
	269	(make-instance 'v-box
	270	:border-width 10 :spacing 10 :parent dialog
	271	:children (loop
	272	for n from 1 to 3
	273	collect (make-instance 'check-button
	274	:label (format nil "Button~D" n)))))
	275
	276
	277
	278	;;; Color selection
	279
	280	(define-dialog create-color-selection (dialog "Color selection dialog"
	281	'color-selection-dialog
	282	:allow-grow nil :allow-shrink nil
	283	:show-children nil)
	284	(with-slots (colorsel) dialog
	285	(let ((button (make-instance 'check-button :label "Show Opacity")))
	286	(dialog-add-action-widget dialog button
	287	#'(lambda ()
	288	(setf
	289	(color-selection-has-opacity-control-p colorsel)
	290	(toggle-button-active-p button)))))
	291
	292	(let ((button (make-instance 'check-button :label "Show Palette")))
	293	(dialog-add-action-widget dialog button
	294	#'(lambda ()
	295	(setf
	296	(color-selection-has-palette-p colorsel)
	297	(toggle-button-active-p button)))))
	298
	299	(signal-connect dialog :ok
	300	#'(lambda ()
	301	(let ((color (color-selection-current-color colorsel)))
	302	(format t "Selected color: ~A~%" color)
	303	(setf (color-selection-current-color colorsel) color)
	304	(widget-hide dialog))))
	305
	306	(signal-connect dialog :cancel #'widget-destroy :object t)))
	307
	308
	309	;;; Cursors
	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
	315	(defun set-cursor (spinner drawing-area label)
	316	(let ((cursor
	317	(glib:int-enum
	318	(logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
	319	'gdk:cursor-type)))
	320	(setf (label-label label) (string-downcase cursor))
	321	(setf (widget-cursor drawing-area) cursor)))
	322
	323	(defun cursor-expose (drawing-area event)
	324	(declare (ignore event))
	325	(multiple-value-bind (width height)
	326	(widget-get-size-allocation drawing-area)
	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
	344	(1- (glib:enum-int :last-cursor 'gdk:cursor-type))
	345	2 10 0)))
	346	(drawing-area (make-instance 'drawing-area
	347	:width-request 80 :height-request 80
	348	:events '(:exposure :button-press)))
	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)
	356	(1 (spin-button-spin spinner :step-forward))
	357	(3 (spin-button-spin spinner :step-backward)))
	358	t))
	359
	360	(signal-connect drawing-area 'scroll-event
	361	#'(lambda (event)
	362	(case (gdk:event-direction event)
	363	(:up (spin-button-spin spinner :step-forward))
	364	(:down (spin-button-spin spinner :step-backward)))
	365	t))
	366
	367	(signal-connect spinner 'changed
	368	#'(lambda ()
	369	(set-cursor spinner drawing-area label)))
	370
	371	(make-instance 'v-box
	372	:parent dialog :border-width 10 :spacing 5
	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
	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)))
	388
	389
	390	;;; Dialog
	391
	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))))))
	411
	412	(if (widget-visible-p dialog)
	413	(widget-hide dialog)
	414	(widget-show dialog))))
	415
	416
	417	;; Entry
	418
	419	(define-simple-dialog create-entry (dialog "Entry")
	420	(let ((main (make-instance 'v-box
	421	:border-width 10 :spacing 10 :parent dialog)))
	422
	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)
	428
	429	(let ((combo (make-instance 'combo-box-entry
	430	:parent main
	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)))
	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)
	456	(create-check-button "Sensitive" 'sensitive)))))
	457
	458
	459	;; Expander
	460
	461	(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
	462	(make-instance 'v-box
	463	:parent dialog :spacing 5 :border-width 5
	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
	469
	470	;; File chooser dialog
	471
	472	(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
	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
	479	(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
	480	(dialog-add-button dialog "gtk-ok"
	481	#'(lambda ()
	482	(if (slot-boundp dialog 'filename)
	483	(format t "Selected file: ~A~%" (file-chooser-filename dialog))
	484	(write-line "No files selected"))
	485	(widget-destroy dialog))))
	486
	487
	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
	497
	498	;;; Icon View
	499
	500	#+gtk2.6
	501	(let ((file-pixbuf nil)
	502	(folder-pixbuf nil))
	503	(defun load-pixbufs ()
	504	(unless file-pixbuf
	505	(handler-case
	506	(setf
	507	file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
	508	folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
	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)
	520	(let ((dir #+cmu(unix:open-dir directory)
	521	#+sbcl(sb-posix:opendir directory)))
	522	(unwind-protect
	523	(loop
	524	as filename = #+cmu(unix:read-dir dir)
	525	#+sbcl(let ((dirent (sb-posix:readdir dir)))
	526	(unless (sb-grovel::foreign-nullp dirent)
	527	(sb-posix:dirent-name dirent)))
	528	while filename
	529	unless (or (equal filename ".") (equal filename ".."))
	530	do (let* ((pathname (format nil "~A~A" directory filename))
	531	(directory-p
	532	#+cmu(eq (unix:unix-file-kind pathname) :directory)
	533	#+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
	534	(list-store-append store
	535	(vector
	536	filename
	537	(if directory-p folder-pixbuf file-pixbuf)
	538	directory-p))))
	539	#+cmu(unix:close-dir dir)
	540	#+sbcl(sb-posix:closedir dir))))
	541
	542	(defun sort-func (store a b)
	543	(let ((a-dir-p (tree-model-value store a 'directory-p))
	544	(b-dir-p (tree-model-value store b 'directory-p))
	545	(a-name (tree-model-value store a 'filename))
	546	(b-name (tree-model-value store b 'filename)))
	547	(cond
	548	((and a-dir-p (not b-dir-p)) :before)
	549	((and (not a-dir-p) b-dir-p) :after)
	550	((string< a-name b-name) :before)
	551	((string> a-name b-name) :after)
	552	(t :equal))))
	553
	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
	569	:text-column 'filename :pixbuf-column 'pixbuf))
	570	(up (make-instance 'tool-button
	571	:stock "gtk-go-up" :is-important t :sensitive nil))
	572	(home (make-instance 'tool-button
	573	:stock "gtk-home" :is-important t)))
	574	(tree-sortable-set-sort-func store :default #'sort-func)
	575	(tree-sortable-set-sort-column store :default :ascending)
	576	(fill-store store directory)
	577
	578	(signal-connect icon-view 'item-activated
	579	#'(lambda (path)
	580	(when (tree-model-value store path 'directory-p)
	581	(setq directory
	582	(concatenate 'string directory (tree-model-value store path 'filename) "/"))
	583	(fill-store store directory)
	584	(setf (widget-sensitive-p up) t))))
	585
	586	(signal-connect up 'clicked
	587	#'(lambda ()
	588	(unless (string= directory "/")
	589	(setq directory (parent-dir directory))
	590	(fill-store store directory)
	591	(setf
	592	(widget-sensitive-p home)
	593	(not (string= directory (namestring (truename #p"clg:")))))
	594	(setf (widget-sensitive-p up) (not (string= directory "/"))))))
	595
	596	(signal-connect home 'clicked
	597	#'(lambda ()
	598	(setq directory (namestring (truename #p"clg:")))
	599	(fill-store store directory)
	600	(setf (widget-sensitive-p up) t)
	601	(setf (widget-sensitive-p home) nil)))
	602
	603	(make-instance 'v-box
	604	:parent window
	605	:child (list
	606	(make-instance 'toolbar :child up :child home)
	607	:fill nil :expand nil)
	608	:child (make-instance 'scrolled-window
	609	:shadow-type :etched-in :policy :automatic
	610	:child icon-view))))))
	611
	612
	613	;;; Image
	614
	615	(define-toplevel create-image (window "Image" :resizable nil)
	616	(make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
	617
	618
	619	;;; Labels
	620
	621	(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
	622	(flet ((create-label-in-frame (frame-label label-text &rest args)
	623	(list
	624	(make-instance 'frame
	625	:label frame-label
	626	:child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
	627	:fill nil :expand nil)))
	628	(make-instance 'h-box
	629	:spacing 5 :parent window
	630	:child-args '(:fill nil :expand nil)
	631	:child (make-instance 'v-box
	632	:spacing 5
	633	:child (create-label-in-frame "Normal Label" "This is a Normal label")
	634	:child (create-label-in-frame "Multi-line Label"
	635	"This is a Multi-line label.
	636	Second line
	637	Third line")
	638	:child (create-label-in-frame "Left Justified Label"
	639	"This is a Left-Justified
	640	Multi-line.
	641	Third line"
	642	:justify :left)
	643	:child (create-label-in-frame "Right Justified Label"
	644	"This is a Right-Justified
	645	Multi-line.
	646	Third line"
	647	:justify :right))
	648	:child (make-instance 'v-box
	649	:spacing 5
	650	:child (create-label-in-frame "Line wrapped label"
	651	"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.
	652	It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
	653	:wrap t)
	654
	655	:child (create-label-in-frame "Filled, wrapped label"
	656	"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.
	657	This is a new paragraph.
	658	This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
	659	:justify :fill :wrap t)
	660
	661	:child (create-label-in-frame "Underlined label"
	662	(#+cmu glib:latin1-to-unicode #+sbcl identity
	663	"This label is underlined!
	664