chiark - git - mdw - 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.34 2006-02-26 23:46:55 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 (Note: using the drawing function in Gdk is considered
	310	;;; deprecated in clg, new code should use Cairo instead)
	311
	312	(defun clamp (n min-val max-val)
	313	(declare (number n min-val max-val))
	314	(max (min n max-val) min-val))
	315
	316	(defun set-cursor (spinner drawing-area label)
	317	(let ((cursor
	318	(glib:int-enum
	319	(logand (clamp (spin-button-value-as-int spinner) 0 152) #xFE)
	320	'gdk:cursor-type)))
	321	(setf (label-label label) (string-downcase cursor))
	322	(setf (widget-cursor drawing-area) cursor)))
	323
	324	(defun cursor-expose (drawing-area event)
	325	(declare (ignore event))
	326	(multiple-value-bind (width height)
	327	(widget-get-size-allocation drawing-area)
	328	(let* ((window (widget-window drawing-area))
	329	(style (widget-style drawing-area))
	330	(white-gc (style-white-gc style))
	331	(gray-gc (style-bg-gc style :normal))
	332	(black-gc (style-black-gc style)))
	333	(gdk:draw-rectangle window white-gc t 0 0 width (floor height 2))
	334	(gdk:draw-rectangle window black-gc t 0 (floor height 2) width
	335	(floor height 2))
	336	(gdk:draw-rectangle window gray-gc t (floor width 3)
	337	(floor height 3) (floor width 3)
	338	(floor height 3))))
	339	t)
	340
	341	(define-simple-dialog create-cursors (dialog "Cursors")
	342	(let ((spinner (make-instance 'spin-button
	343	:adjustment (adjustment-new
	344	0 0
	345	(1- (glib:enum-int :last-cursor 'gdk:cursor-type))
	346	2 10 0)))
	347	(drawing-area (make-instance 'drawing-area
	348	:width-request 80 :height-request 80
	349	:events '(:exposure :button-press)))
	350	(label (make-instance 'label :label "XXX")))
	351
	352	(signal-connect drawing-area 'expose-event #'cursor-expose :object t)
	353
	354	(signal-connect drawing-area 'button-press-event
	355	#'(lambda (event)
	356	(case (gdk:event-button event)
	357	(1 (spin-button-spin spinner :step-forward))
	358	(3 (spin-button-spin spinner :step-backward)))
	359	t))
	360
	361	(signal-connect drawing-area 'scroll-event
	362	#'(lambda (event)
	363	(case (gdk:event-direction event)
	364	(:up (spin-button-spin spinner :step-forward))
	365	(:down (spin-button-spin spinner :step-backward)))
	366	t))
	367
	368	(signal-connect spinner 'changed
	369	#'(lambda ()
	370	(set-cursor spinner drawing-area label)))
	371
	372	(make-instance 'v-box
	373	:parent dialog :border-width 10 :spacing 5
	374	:child (list
	375	(make-instance 'h-box
	376	:border-width 5
	377	:child (list
	378	(make-instance 'label :label "Cursor Value : ")
	379	:expand nil)
	380	:child spinner)
	381	:expand nil)
	382	:child (make-instance 'frame
	383	:label "Cursor Area" :label-xalign 0.5 :border-width 10
	384	:child drawing-area)
	385	:child (list label :expand nil))
	386
	387	(widget-realize drawing-area)
	388	(set-cursor spinner drawing-area label)))
	389
	390
	391	;;; Dialog
	392
	393	(let ((dialog nil))
	394	(defun create-dialog ()
	395	(unless dialog
	396	(setq dialog (make-instance 'dialog
	397	:title "Dialog" :default-width 200
	398	:button "Toggle"
	399	:button (list "gtk-ok" #'widget-destroy :object t)
	400	:signal (list 'destroy
	401	#'(lambda ()
	402	(setq dialog nil)))))
	403
	404	(let ((label (make-instance 'label
	405	:label "Dialog Test" :xpad 10 :ypad 10 :visible t
	406	:parent dialog)))
	407	(signal-connect dialog "Toggle"
	408	#'(lambda ()
	409	(if (widget-visible-p label)
	410	(widget-hide label)
	411	(widget-show label))))))
	412
	413	(if (widget-visible-p dialog)
	414	(widget-hide dialog)
	415	(widget-show dialog))))
	416
	417
	418	;; Entry
	419
	420	(define-simple-dialog create-entry (dialog "Entry")
	421	(let ((main (make-instance 'v-box
	422	:border-width 10 :spacing 10 :parent dialog)))
	423
	424	(let ((entry (make-instance 'entry :text "hello world" :parent main)))
	425	(editable-select-region entry 0 5) ; this has no effect when
	426	; entry is editable
	427	;; (editable-insert-text entry "great " 6)
	428	;; (editable-delete-text entry 6 12)
	429
	430	(let ((combo (make-instance 'combo-box-entry
	431	:parent main
	432	:content '("item0"
	433	"item1 item1"
	434	"item2 item2 item2"
	435	"item3 item3 item3 item3"
	436	"item4 item4 item4 item4 item4"
	437	"item5 item5 item5 item5 item5 item5"
	438	"item6 item6 item6 item6 item6"
	439	"item7 item7 item7 item7"
	440	"item8 item8 item8"
	441	"item9 item9"))))
	442	(with-slots (child) combo
	443	(setf (editable-text child) "hello world")
	444	(editable-select-region child 0)))
	445
	446	(flet ((create-check-button (label slot)
	447	(make-instance 'check-button
	448	:label label :active t :parent main
	449	:signal (list 'toggled
	450	#'(lambda (button)
	451	(setf (slot-value entry slot)
	452	(toggle-button-active-p button)))
	453	:object t))))
	454
	455	(create-check-button "Editable" 'editable)
	456	(create-check-button "Visible" 'visibility)
	457	(create-check-button "Sensitive" 'sensitive)))))
	458
	459
	460	;; Expander
	461
	462	(define-simple-dialog create-expander (dialog "Expander" :resizable nil)
	463	(make-instance 'v-box
	464	:parent dialog :spacing 5 :border-width 5
	465	:child (create-label "Expander demo. Click on the triangle for details.")
	466	:child (make-instance 'expander
	467	:label "Details"
	468	:child (create-label "Details can be shown or hidden."))))
	469
	470
	471	;; File chooser dialog
	472
	473	(define-dialog create-file-chooser (dialog "File Chooser" 'file-chooser-dialog)
	474	(file-chooser-add-filter dialog
	475	(make-instance 'file-filter :name "All files" :pattern "*"))
	476	(file-chooser-add-filter dialog
	477	(make-instance 'file-filter :name "Common Lisp source code"
	478	:patterns '(".lisp" ".lsp")))
	479
	480	(dialog-add-button dialog "gtk-cancel" #'widget-destroy :object t)
	481	(dialog-add-button dialog "gtk-ok"
	482	#'(lambda ()
	483	(if (slot-boundp dialog 'filename)
	484	(format t "Selected file: ~A~%" (file-chooser-filename dialog))
	485	(write-line "No files selected"))
	486	(widget-destroy dialog))))
	487
	488
	489	;; Font selection dialog
	490
	491	(define-toplevel create-font-selection (window "Font Button" :resizable nil)
	492	(make-instance 'h-box
	493	:parent window :spacing 8 :border-width 8
	494	:child (make-instance 'label :label "Pick a font")
	495	:child (make-instance 'font-button
	496	:use-font t :title "Font Selection Dialog")))
	497
	498
	499	;;; Icon View
	500
	501	#+gtk2.6
	502	(let ((file-pixbuf nil)
	503	(folder-pixbuf nil))
	504	(defun load-pixbufs ()
	505	(unless file-pixbuf
	506	(handler-case
	507	(setf
	508	file-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-regular.png")
	509	folder-pixbuf (gdk:pixbuf-load #p"clg:examples;gnome-fs-directory.png"))
	510	(glib:glib-error (condition)
	511	(make-instance 'message-dialog
	512	:message-type :error :visible t
	513	:text "<b>Failed to load an image</b>"
	514	:secondary-text (glib:gerror-message condition)
	515	:signal (list :close #'widget-destroy :object t))
	516	(return-from load-pixbufs nil))))
	517	t)
	518
	519	(defun fill-store (store directory)
	520	(list-store-clear store)
	521	(let ((dir #+cmu(unix:open-dir directory)
	522	#+sbcl(sb-posix:opendir directory)))
	523	(unwind-protect
	524	(loop
	525	as filename = #+cmu(unix:read-dir dir)
	526	#+sbcl(let ((dirent (sb-posix:readdir dir)))
	527	(unless (sb-grovel::foreign-nullp dirent)
	528	(sb-posix:dirent-name dirent)))
	529	while filename
	530	unless (or (equal filename ".") (equal filename ".."))
	531	do (let* ((pathname (format nil "~A~A" directory filename))
	532	(directory-p
	533	#+cmu(eq (unix:unix-file-kind pathname) :directory)
	534	#+sbcl(sb-posix:s-isdir (sb-posix:stat-mode (sb-posix:stat pathname)))))
	535	(list-store-append store
	536	(vector
	537	filename
	538	(if directory-p folder-pixbuf file-pixbuf)
	539	directory-p))))
	540	#+cmu(unix:close-dir dir)
	541	#+sbcl(sb-posix:closedir dir))))
	542
	543	(defun sort-func (store a b)
	544	(let ((a-dir-p (tree-model-value store a 'directory-p))
	545	(b-dir-p (tree-model-value store b 'directory-p))
	546	(a-name (tree-model-value store a 'filename))
	547	(b-name (tree-model-value store b 'filename)))
	548	(cond
	549	((and a-dir-p (not b-dir-p)) :before)
	550	((and (not a-dir-p) b-dir-p) :after)
	551	((string< a-name b-name) :before)
	552	((string> a-name b-name) :after)
	553	(t :equal))))
	554
	555	(defun parent-dir (dir)
	556	(let ((end (1+ (position #\/ dir :from-end t :end (1- (length dir))))))
	557	(subseq dir 0 end)))
	558
	559	(define-toplevel create-icon-view (window "Icon View demo"
	560	:default-width 650
	561	:default-height 400)
	562	(if (not (load-pixbufs))
	563	(widget-destroy window)
	564	(let* ((directory "/")
	565	(store (make-instance 'list-store
	566	:column-types '(string gdk:pixbuf boolean)
	567	:column-names '(filename pixbuf directory-p)))
	568	(icon-view (make-instance 'icon-view
	569	:model store :selection-mode :multiple
	570	:text-column 'filename :pixbuf-column 'pixbuf))
	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
	583	(concatenate 'string directory (tree-model-value store path 'filename) "/"))
	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
	614	;;; Image
	615
	616	(define-toplevel create-image (window "Image" :resizable nil)
	617	(make-instance 'image :file #p"clg:examples;gtk.png" :parent window))
	618
	619
	620	;;; Labels
	621
	622	(define-toplevel create-labels (window "Labels" :border-width 5 :resizable nil)
	623	(flet ((create-label-in-frame (frame-label label-text &rest args)
	624	(list
	625	(make-instance 'frame
	626	:label frame-label
	627	:child (apply #'make-instance 'label :label label-text :xpad 5 :ypad 5 args))
	628	:fill nil :expand nil)))
	629	(make-instance 'h-box
	630	:spacing 5 :parent window
	631	:child-args '(:fill nil :expand nil)
	632	:child (make-instance 'v-box
	633	:spacing 5
	634	:child (create-label-in-frame "Normal Label" "This is a Normal label")
	635	:child (create-label-in-frame "Multi-line Label"
	636	"This is a Multi-line label.
	637	Second line
	638	Third line")
	639	:child (create-label-in-frame "Left Justified Label"
	640	"This is a Left-Justified
	641	Multi-line.
	642	Third line"
	643	:justify :left)
	644	:child (create-label-in-frame "Right Justified Label"
	645	"This is a Right-Justified
	646	Multi-line.
	647	Third line"
	648	:justify :right))
	649	:child (make-instance 'v-box
	650	:spacing 5
	651	:child (create-label-in-frame "Line wrapped label"
	652	"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.
	653	It supports multiple paragraphs correctly, and correctly adds many extra spaces. "
	654	:wrap t)
	655
	656	:child (create-label-in-frame "Filled, wrapped label"
	657	"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.
	658	This is a new paragraph.
	659	This is another newer, longer, better paragraph. It is coming to an end, unfortunately."
	660	:justify :fill :wrap t)
	661
	662	:child (create-label-in-frame "Underlined label"
	663	(#+cmu glib:latin1-to-unicode #+sbcl identity
	664	"This label is underlined!
	665