ViewVC Help

View File | Revision Log | Show Annotations | Download File

/cvs/deliantra/Deliantra-Client/DC/UI.pm

Comparing deliantra/Deliantra-Client/DC/UI.pm (file contents):
Revision 1.173 by root, Tue Apr 25 10:30:48 2006 UTC vs.
Revision 1.267 by root, Thu Jun 1 04:10:29 2006 UTC

1	package CFClient::UI;	1	package CFClient::UI;
2		2
		3	use utf8;
3	use strict;	4	use strict;
4		5
5	use Scalar::Util ();	6	use Scalar::Util ();
6	use List::Util ();	7	use List::Util ();
7		8
8	use CFClient;	9	use CFClient;
		10	use CFClient::Texture;
9		11
10	our ($FOCUS, $HOVER, $GRAB); # various widgets	12	our ($FOCUS, $HOVER, $GRAB); # various widgets
11		13
		14	our $LAYOUT;
12	our $ROOT;	15	our $ROOT;
13	our $TOOLTIP;	16	our $TOOLTIP;
14	our $BUTTON_STATE;	17	our $BUTTON_STATE;
15		18
		19	our %WIDGET; # all widgets, weak-referenced
		20
		21	sub get_layout {
		22	my $layout;
		23
		24	for (grep { $_->{name} } values %WIDGET) {
		25	my $win = $layout->{$_->{name}} = { };
		26
		27	$win->{x} = ($_->{x} + $_->{w} * 0.5) / $::WIDTH if $_->{x} =~ /^[0-9.]+$/;
		28	$win->{y} = ($_->{y} + $_->{h} * 0.5) / $::HEIGHT if $_->{y} =~ /^[0-9.]+$/;
		29	$win->{w} = $_->{w} / $::WIDTH if defined $_->{w};
		30	$win->{h} = $_->{h} / $::HEIGHT if defined $_->{h};
		31
		32	$win->{show} = $_->{visible} && $_->{is_toplevel};
		33	}
		34
		35	$layout
		36	}
		37
		38	sub set_layout {
		39	my ($layout) = @_;
		40
		41	$LAYOUT = $layout;
		42	}
		43
16	sub check_tooltip {	44	sub check_tooltip {
		45	return if $ENV{CFPLUS_DEBUG} & 8;
		46
17	if (!$GRAB) {	47	if (!$GRAB) {
18	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {	48	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {
19	if (length $widget->{tooltip}) {	49	if (length $widget->{tooltip}) {
20
21	if ($TOOLTIP->{owner} != $widget) {	50	if ($TOOLTIP->{owner} != $widget) {
		51	$TOOLTIP->hide;
		52
22	$TOOLTIP->{owner} = $widget;	53	$TOOLTIP->{owner} = $widget;
23		54
24	my $tip = $widget->{tooltip};	55	my $tip = $widget->{tooltip};
25		56
26	$tip = $tip->($widget) if CODE:: eq ref $tip;	57	$tip = $tip->($widget) if CODE:: eq ref $tip;
27		58
28	$TOOLTIP->set_markup ($widget->{tooltip});	59	$TOOLTIP->set_tooltip_from ($widget);
29	$TOOLTIP->move ($widget->coord2global ($widget->{w}, 0));
30	$TOOLTIP->show;	60	$TOOLTIP->show;
31	}	61	}
32		62
33	return;	63	return;
34	}	64	}
…		…
39	delete $TOOLTIP->{owner};	69	delete $TOOLTIP->{owner};
40	}	70	}
41		71
42	# class methods for events	72	# class methods for events
43	sub feed_sdl_key_down_event {	73	sub feed_sdl_key_down_event {
44	$FOCUS->emit (key_down => $_[0]) || $FOCUS->key_down ($_[0])	74	$FOCUS->emit (key_down => $_[0])
45	if $FOCUS;	75	if $FOCUS;
46	}	76	}
47		77
48	sub feed_sdl_key_up_event {	78	sub feed_sdl_key_up_event {
49	$FOCUS->emit (key_up => $_[0]) || $FOCUS->key_up ($_[0])	79	$FOCUS->emit (key_up => $_[0])
50	if $FOCUS;	80	if $FOCUS;
51	}	81	}
52		82
53	sub feed_sdl_button_down_event {	83	sub feed_sdl_button_down_event {
54	my ($ev) = @_;	84	my ($ev) = @_;
…		…
63	check_tooltip;	93	check_tooltip;
64	}	94	}
65		95
66	$BUTTON_STATE |= 1 << ($ev->{button} - 1);	96	$BUTTON_STATE |= 1 << ($ev->{button} - 1);
67		97
68	if ($GRAB) {	98	$GRAB->emit (button_down => $ev, $GRAB->coord2local ($x, $y))
69	($x, $y) = $GRAB->coord2local ($x, $y);	99	if $GRAB;
70	$GRAB->emit (button_down => $ev, $x, $y) || $GRAB->button_down ($ev, $x, $y);
71	}
72	}	100	}
73		101
74	sub feed_sdl_button_up_event {	102	sub feed_sdl_button_up_event {
75	my ($ev) = @_;	103	my ($ev) = @_;
76	my ($x, $y) = ($ev->{x}, $ev->{y});	104	my ($x, $y) = ($ev->{x}, $ev->{y});
77		105
78	my $widget = $GRAB || $ROOT->find_widget ($x, $y);	106	my $widget = $GRAB || $ROOT->find_widget ($x, $y);
79		107
80	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));	108	$BUTTON_STATE &= ~(1 << ($ev->{button} - 1));
81		109
82	if ($GRAB) {	110	$GRAB->emit (button_up => $ev, $GRAB->coord2local ($x, $y))
83	($x, $y) = $GRAB->coord2local ($x, $y);	111	if $GRAB;
84	$GRAB->emit (button_up => $ev, $x, $y) || $GRAB->button_up ($ev, $x, $y);
85	}
86		112
87	if (!$BUTTON_STATE) {	113	if (!$BUTTON_STATE) {
88	my $grab = $GRAB; undef $GRAB;	114	my $grab = $GRAB; undef $GRAB;
89	$grab->update if $grab;	115	$grab->update if $grab;
90	$GRAB->update if $GRAB;	116	$GRAB->update if $GRAB;
…		…
106	$HOVER->update if $HOVER && $HOVER->{can_hover};	132	$HOVER->update if $HOVER && $HOVER->{can_hover};
107		133
108	check_tooltip;	134	check_tooltip;
109	}	135	}
110		136
111	if ($HOVER) {
112	($x, $y) = $HOVER->coord2local ($x, $y);
113	$HOVER->emit (mouse_motion => $ev, $x, $y) || $HOVER->mouse_motion ($ev, $x, $y);	137	$HOVER->emit (mouse_motion => $ev, $HOVER->coord2local ($x, $y))
114	}	138	if $HOVER;
115	}	139	}
116		140
117	# convert position array to integers	141	# convert position array to integers
118	sub harmonize {	142	sub harmonize {
119	my ($vals) = @_;	143	my ($vals) = @_;
…		…
125	$rem += $_ - $i;	149	$rem += $_ - $i;
126	$_ = $i;	150	$_ = $i;
127	}	151	}
128	}	152	}
129		153
		154	sub full_refresh {
		155	# make a copy, otherwise for complains about freed values.
		156	my @widgets = values %WIDGET;
		157
		158	$_->update
		159	for @widgets;
		160	}
		161
		162	sub reconfigure_widgets {
		163	# make a copy, otherwise C<for> complains about freed values.
		164	my @widgets = values %WIDGET;
		165
		166	$_->reconfigure
		167	for @widgets;
		168	}
		169
		170	# call when resolution changes etc.
		171	sub rescale_widgets {
		172	my ($sx, $sy) = @_;
		173
		174	for my $widget (values %WIDGET) {
		175	if ($widget->{is_toplevel}) {
		176	$widget->{x} += $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
		177	$widget->{y} += $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
		178
		179	$widget->{x} = int 0.5 + $widget->{x} * $sx if $widget->{x} =~ /^[0-9.]+$/;
		180	$widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w};
		181	$widget->{force_w} = int 0.5 + $widget->{force_w} * $sx if exists $widget->{force_w};
		182	$widget->{y} = int 0.5 + $widget->{y} * $sy if $widget->{y} =~ /^[0-9.]+$/;
		183	$widget->{h} = int 0.5 + $widget->{h} * $sy if exists $widget->{h};
		184	$widget->{force_h} = int 0.5 + $widget->{force_h} * $sy if exists $widget->{force_h};
		185
		186	$widget->{x} -= $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
		187	$widget->{y} -= $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
		188
		189	}
		190	}
		191
		192	reconfigure_widgets;
		193	}
		194
130	#############################################################################	195	#############################################################################
131		196
132	package CFClient::UI::Base;	197	package CFClient::UI::Base;
133		198
134	use strict;	199	use strict;
…		…
137		202
138	sub new {	203	sub new {
139	my $class = shift;	204	my $class = shift;
140		205
141	my $self = bless {	206	my $self = bless {
142	x => 0,	207	x => "center",
143	y => 0,	208	y => "center",
144	z => 0,	209	z => 0,
		210	w => undef,
		211	h => undef,
145	can_events => 1,	212	can_events => 1,
146	@_	213	@_
147	}, $class;	214	}, $class;
148		215
		216	Scalar::Util::weaken ($CFClient::UI::WIDGET{$self+0} = $self);
		217
149	for (keys %$self) {	218	for (keys %$self) {
150	if (/^connect_(.*)$/) {	219	if (/^on_(.*)$/) {
151	$self->connect ($1 => delete $self->{$_});	220	$self->connect ($1 => delete $self->{$_});
152	}	221	}
153	}	222	}
154		223
		224	if (my $layout = $CFClient::UI::LAYOUT->{$self->{name}}) {
		225	$self->{x} = $layout->{x} * $CFClient::UI::ROOT->{alloc_w} if exists $layout->{x};
		226	$self->{y} = $layout->{y} * $CFClient::UI::ROOT->{alloc_h} if exists $layout->{y};
		227	$self->{force_w} = $layout->{w} * $CFClient::UI::ROOT->{alloc_w} if exists $layout->{w};
		228	$self->{force_h} = $layout->{h} * $CFClient::UI::ROOT->{alloc_h} if exists $layout->{h};
		229
		230	$self->{x} -= $self->{force_w} * 0.5 if exists $layout->{x};
		231	$self->{y} -= $self->{force_h} * 0.5 if exists $layout->{y};
		232
		233	$self->show if $layout->{show};
		234	}
		235
155	$self	236	$self
156	}	237	}
157		238
158	sub destroy {	239	sub destroy {
159	my ($self) = @_;	240	my ($self) = @_;
…		…
168	return if $self->{parent};	249	return if $self->{parent};
169		250
170	$CFClient::UI::ROOT->add ($self);	251	$CFClient::UI::ROOT->add ($self);
171	}	252	}
172		253
173	sub hide {	254	sub set_visible {
174	my ($self) = @_;	255	my ($self) = @_;
		256
		257	return if $self->{visible};
		258
		259	$self->{root} = $self->{parent}{root};
		260	$self->{visible} = $self->{parent}{visible} + 1;
		261
		262	$self->emit (visibility_change => 1);
		263
		264	$self->realloc if !exists $self->{req_w};
		265
		266	$_->set_visible for $self->children;
		267	}
		268
		269	sub set_invisible {
		270	my ($self) = @_;
		271
		272	return unless $self->{visible};
		273
		274	$_->set_invisible for $self->children;
		275
		276	delete $self->{root};
		277	delete $self->{visible};
175		278
176	undef $GRAB if $GRAB == $self;	279	undef $GRAB if $GRAB == $self;
177	undef $HOVER if $HOVER == $self;	280	undef $HOVER if $HOVER == $self;
178		281
		282	CFClient::UI::check_tooltip
		283	if $TOOLTIP->{owner} == $self;
		284
		285	$self->focus_out;
		286
		287	$self->emit (visibility_change => 0);
		288	}
		289
		290	sub set_visibility {
		291	my ($self, $visible) = @_;
		292
		293	return if $self->{visible} == $visible;
		294
		295	$visible ? $self->hide
		296	: $self->show;
		297	}
		298
		299	sub toggle_visibility {
		300	my ($self) = @_;
		301
		302	$self->{visible}
		303	? $self->hide
		304	: $self->show;
		305	}
		306
		307	sub hide {
		308	my ($self) = @_;
		309
		310	$self->set_invisible;
		311
179	$self->{parent}->remove ($self)	312	$self->{parent}->remove ($self)
180	if $self->{parent};	313	if $self->{parent};
181	}	314	}
182		315
183	sub move {	316	sub move_abs {
184	my ($self, $x, $y, $z) = @_;	317	my ($self, $x, $y, $z) = @_;
185		318
186	$self->{x} = int $x;	319	$self->{x} = List::Util::max 0, int $x;
187	$self->{y} = int $y;	320	$self->{y} = List::Util::max 0, int $y;
188	$self->{z} = $z if defined $z;	321	$self->{z} = $z if defined $z;
189		322
190	$self->update;	323	$self->update;
191	}	324	}
192		325
193	sub set_size {	326	sub set_size {
194	my ($self, $w, $h) = @_;	327	my ($self, $w, $h) = @_;
195		328
196	$self->{user_w} = $w;	329	$self->{force_w} = $w;
197	$self->{user_h} = $h;	330	$self->{force_h} = $h;
198		331
199	$self->check_size;	332	$self->realloc;
200	}	333	}
201		334
202	sub size_request {	335	sub size_request {
203	require Carp;	336	require Carp;
204	Carp::confess "size_request is abstract";	337	Carp::confess "size_request is abstract";
…		…
206		339
207	sub configure {	340	sub configure {
208	my ($self, $x, $y, $w, $h) = @_;	341	my ($self, $x, $y, $w, $h) = @_;
209		342
210	if ($self->{aspect}) {	343	if ($self->{aspect}) {
		344	my ($ow, $oh) = ($w, $h);
		345
211	my $w2 = List::Util::min $w, int $h * $self->{aspect};	346	$w = List::Util::min $w, int $h * $self->{aspect};
212	my $h2 = List::Util::min $h, int $w / $self->{aspect};	347	$h = List::Util::min $h, int $w / $self->{aspect};
213		348
214	# use alignment to adjust x, y	349	# use alignment to adjust x, y
215		350
216	$x += int +($w - $w2) * 0.5;	351	$x += int 0.5 * ($ow - $w);
217	$y += int +($h - $h2) * 0.5;	352	$y += int 0.5 * ($oh - $h);
218
219	($w, $h) = ($w2, $h2);
220	}	353	}
221		354
222	if ($self->{x} != $x || $self->{y} != $y) {	355	if ($self->{x} ne $x || $self->{y} ne $y) {
223	$self->{x} = $x;	356	$self->{x} = $x;
224	$self->{y} = $y;	357	$self->{y} = $y;
225	$self->update;	358	$self->update;
226	}	359	}
227		360
228	if ($self->{w} != $w || $self->{h} != $h) {	361	if ($self->{alloc_w} != $w || $self->{alloc_h} != $h) {
		362	return unless $self->{visible};
		363
229	$self->{w} = $w;	364	$self->{alloc_w} = $w;
230	$self->{h} = $h;	365	$self->{alloc_h} = $h;
231		366
232	$self->size_allocate ($w, $h);	367	$self->{root}{size_alloc}{$self+0} = $self;
233	$self->update;
234	}	368	}
235	}	369	}
236		370
237	sub size_allocate {	371	sub size_allocate {
238	# nothing to be done	372	# nothing to be done
239	}	373	}
240		374
241	sub children {	375	sub children {
242	}	376	}
243		377
244	# call when resoltuion changes etc.
245	sub reconfigure {
246	my ($self) = @_;
247
248	$_->reconfigure
249	for $self->children;
250
251	$_->check_size;
252	}
253
254	sub set_max_size {	378	sub set_max_size {
255	my ($self, $w, $h) = @_;	379	my ($self, $w, $h) = @_;
256		380
257	delete $self->{max_w}; $self->{max_w} = $w if $w;	381	delete $self->{max_w}; $self->{max_w} = $w if $w;
258	delete $self->{max_h}; $self->{max_h} = $h if $h;	382	delete $self->{max_h}; $self->{max_h} = $h if $h;
259	}	383	}
260		384
261	# return top left coordinates	385	sub set_tooltip {
262	sub _topleft {
263	my ($self, $x, $y) = @_;	386	my ($self, $tooltip) = @_;
264		387
265	$self->{parent}	388	$tooltip =~ s/^\s+//;
266	or Carp::confess "no parent widget in _topleft\n";#d#	389	$tooltip =~ s/\s+$//;
267		390
268	$self->{parent}->_topleft ($x + $self->{x}, $y + $self->{y});	391	return if $self->{tooltip} eq $tooltip;
		392
		393	$self->{tooltip} = $tooltip;
		394
		395	if ($CFClient::UI::TOOLTIP->{owner} == $self) {
		396	delete $CFClient::UI::TOOLTIP->{owner};
		397	CFClient::UI::check_tooltip;
		398	}
269	}	399	}
270		400
271	# translate global coordinates to local coordinate system	401	# translate global coordinates to local coordinate system
272	sub coord2local {	402	sub coord2local {
273	my ($self, $x, $y) = @_;	403	my ($self, $x, $y) = @_;
274		404
275	my ($X, $Y) = $self->_topleft;	405	$self->{parent}->coord2local ($x - $self->{x}, $y - $self->{y})
276	($x - $X, $y - $Y)
277	}	406	}
278		407
279	# translate local coordinates to global coordinate system	408	# translate local coordinates to global coordinate system
280	sub coord2global {	409	sub coord2global {
281	my ($self, $x, $y) = @_;	410	my ($self, $x, $y) = @_;
282		411
283	my ($X, $Y) = $self->_topleft;	412	$self->{parent}->coord2global ($x + $self->{x}, $y + $self->{y})
284	($x + $X, $y + $Y)
285	}	413	}
286		414
287	sub focus_in {	415	sub focus_in {
288	my ($self) = @_;	416	my ($self) = @_;
289		417
290	return if $FOCUS == $self;	418	return if $FOCUS == $self;
291	return unless $self->{can_focus};	419	return unless $self->{can_focus};
292		420
293	my $focus = $FOCUS; $FOCUS = $self;	421	my $focus = $FOCUS; $FOCUS = $self;
294		422
295	$self->emit (focus_in => $focus);	423	$self->_emit (focus_in => $focus);
296		424
297	$focus->update if $focus;	425	$focus->update if $focus;
298	$FOCUS->update;	426	$FOCUS->update;
299	}	427	}
300		428
…		…
303		431
304	return unless $FOCUS == $self;	432	return unless $FOCUS == $self;
305		433
306	my $focus = $FOCUS; undef $FOCUS;	434	my $focus = $FOCUS; undef $FOCUS;
307		435
308	$self->emit (focus_out => $focus);	436	$self->_emit (focus_out => $focus);
309		437
310	$focus->update if $focus; #?	438	$focus->update if $focus; #?
		439
		440	$::MAPWIDGET->focus_in #d# focus mapwidget if no other widget has focus
		441	unless $FOCUS;
311	}	442	}
312		443
313	sub mouse_motion { }	444	sub mouse_motion { }
314	sub button_up { }	445	sub button_up { }
315	sub key_down { }	446	sub key_down { }
316	sub key_up { }	447	sub key_up { }
317		448
318	sub button_down {	449	sub button_down {
319	my ($self, $ev, $x, $y) = @_;	450	my ($self, $ev, $x, $y) = @_;
320		451
321	$self->focus_in;	452	$self->focus_in;
322	}	453	}
323		454
324	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }	455	sub find_widget {
325	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }	456	my ($self, $x, $y) = @_;
326	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }	457
327	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }	458	return () unless $self->{can_events};
328	sub z { $_[0]{z} = $_[1] if @_ > 1; $_[0]{z} }	459
		460	return $self
		461	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
		462	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
		463
		464	()
		465	}
		466
		467	sub set_parent {
		468	my ($self, $parent) = @_;
		469
		470	Scalar::Util::weaken ($self->{parent} = $parent);
		471	$self->set_visible if $parent->{visible};
		472	}
		473
		474	sub connect {
		475	my ($self, $signal, $cb) = @_;
		476
		477	push @{ $self->{signal_cb}{$signal} }, $cb;
		478	}
		479
		480	sub _emit {
		481	my ($self, $signal, @args) = @_;
		482
		483	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
		484	}
		485
		486	sub emit {
		487	my ($self, $signal, @args) = @_;
		488
		489	$self->_emit ($signal, @args)
		490	|| $self->$signal (@args);
		491	}
		492
		493	sub visibility_change {
		494	#my ($self, $visible) = @_;
		495	}
		496
		497	sub realloc {
		498	my ($self) = @_;
		499
		500	if ($self->{visible}) {
		501	return if $self->{root}{realloc}{$self+0};
		502
		503	$self->{root}{realloc}{$self+0} = $self;
		504	$self->{root}->update;
		505	} else {
		506	delete $self->{req_w};
		507	delete $self->{req_h};
		508	}
		509	}
		510
		511	sub update {
		512	my ($self) = @_;
		513
		514	$self->{parent}->update
		515	if $self->{parent};
		516	}
		517
		518	sub reconfigure {
		519	my ($self) = @_;
		520
		521	$self->realloc;
		522	$self->update;
		523	}
		524
		525	# using global variables seems a bit hacky, but passing through all drawing
		526	# functions seems pointless.
		527	our ($draw_x, $draw_y, $draw_w, $draw_h); # screen rectangle being drawn
329		528
330	sub draw {	529	sub draw {
331	my ($self) = @_;	530	my ($self) = @_;
332		531
333	return unless $self->{h} && $self->{w};	532	return unless $self->{h} && $self->{w};
		533
		534	local $draw_x = $draw_x + $self->{x};
		535	local $draw_y = $draw_y + $self->{y};
		536
		537	return if $draw_x + $self->{w} < 0;
		538	return if $draw_x >= $draw_w;
		539	return if $draw_y + $self->{h} < 0;
		540	return if $draw_y >= $draw_h;
334		541
335	glPushMatrix;	542	glPushMatrix;
336	glTranslate $self->{x}, $self->{y}, 0;	543	glTranslate $self->{x}, $self->{y}, 0;
337	$self->_draw;	544	$self->_draw;
338	glPopMatrix;	545	glPopMatrix;
…		…
350	glVertex $x , $y + $self->{h};	557	glVertex $x , $y + $self->{h};
351	glEnd;	558	glEnd;
352	glDisable GL_BLEND;	559	glDisable GL_BLEND;
353	}	560	}
354		561
355	if ($ENV{PCLIENT_DEBUG}) {	562	if ($ENV{CFPLUS_DEBUG} & 1) {
356	glPushMatrix;	563	glPushMatrix;
357	glColor 1, 1, 0, 1;	564	glColor 1, 1, 0, 1;
358	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;	565	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;
359	glBegin GL_LINE_LOOP;	566	glBegin GL_LINE_LOOP;
360	glVertex 0 , 0;	567	glVertex 0 , 0;
361	glVertex $self->{w}, 0;	568	glVertex $self->{w} - 1, 0;
362	glVertex $self->{w}, $self->{h};	569	glVertex $self->{w} - 1, $self->{h} - 1;
363	glVertex 0 , $self->{h};	570	glVertex 0 , $self->{h} - 1;
364	glEnd;	571	glEnd;
365	glPopMatrix;	572	glPopMatrix;
366	CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;	573	#CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;
367	}	574	}
368	}	575	}
369		576
370	sub _draw {	577	sub _draw {
371	my ($self) = @_;	578	my ($self) = @_;
372		579
373	warn "no draw defined for $self\n";	580	warn "no draw defined for $self\n";
374	}	581	}
375		582
376	sub find_widget {
377	my ($self, $x, $y) = @_;
378
379	return () unless $self->{can_events};
380
381	return $self
382	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
383	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
384
385	()
386	}
387
388	sub set_parent {
389	my ($self, $parent) = @_;
390
391	Scalar::Util::weaken ($self->{parent} = $parent);
392	}
393
394	sub check_size {
395	my ($self) = @_;
396
397	$self->{parent}
398	or return 1;
399
400	my ($w, $h) = $self->{user_w} && $self->{user_h}
401	? @$self{qw(user_w user_h)}
402	: $self->size_request;
403
404	if ($w != $self->{req_w} || $h != $self->{req_h}) {
405	$self->{req_w} = $w;
406	$self->{req_h} = $h;
407
408	$self->{parent}->check_size
409	or $self->size_allocate (
410	(List::Util::max $self->{w}, $w),
411	(List::Util::max $self->{h}, $h),
412	);
413
414	1
415	} else {
416	0
417	}
418	}
419
420	sub update {
421	my ($self) = @_;
422
423	$self->{parent}->update
424	if $self->{parent};
425	}
426
427	sub connect {
428	my ($self, $signal, $cb) = @_;
429
430	push @{ $self->{signal_cb}{$signal} }, $cb;
431	}
432
433	sub emit {
434	my ($self, $signal, @args) = @_;
435
436	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
437	}
438
439	sub DESTROY {	583	sub DESTROY {
440	my ($self) = @_;	584	my ($self) = @_;
441		585
		586	delete $WIDGET{$self+0};
442	#$self->deactivate;	587	#$self->deactivate;
443	}	588	}
444		589
445	#############################################################################	590	#############################################################################
446		591
…		…
455	my $class = shift;	600	my $class = shift;
456		601
457	# range [value, low, high, page]	602	# range [value, low, high, page]
458		603
459	$class->SUPER::new (	604	$class->SUPER::new (
460	bg => [0, 0, 0, 0.2],	605	#bg => [0, 0, 0, 0.2],
461	active_bg => [1, 1, 1, 0.5],	606	#active_bg => [1, 1, 1, 0.5],
462	@_	607	@_
463	)	608	)
464	}	609	}
465		610
466	sub _draw {	611	sub _draw {
467	my ($self) = @_;	612	my ($self) = @_;
468		613
		614	my $color = $FOCUS == $self && $self->{active_bg}
		615	? $self->{active_bg}
		616	: $self->{bg};
		617
		618	if ($color && (@$color < 4 || $color->[3])) {
469	my ($w, $h) = @$self{qw(w h)};	619	my ($w, $h) = @$self{qw(w h)};
470		620
471	glEnable GL_BLEND;	621	glEnable GL_BLEND;
472	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	622	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
473	glColor @{ $FOCUS == $self ? $self->{active_bg} : $self->{bg} };	623	glColor @$color;
474		624
475	glBegin GL_QUADS;	625	glBegin GL_QUADS;
476	glVertex 0 , 0;	626	glVertex 0 , 0;
477	glVertex 0 , $h;	627	glVertex 0 , $h;
478	glVertex $w, $h;	628	glVertex $w, $h;
479	glVertex $w, 0;	629	glVertex $w, 0;
480	glEnd;	630	glEnd;
481		631
482	glDisable GL_BLEND;	632	glDisable GL_BLEND;
		633	}
483	}	634	}
484		635
485	#############################################################################	636	#############################################################################
486		637
487	package CFClient::UI::Empty;	638	package CFClient::UI::Empty;
…		…
492	my ($class, %arg) = @_;	643	my ($class, %arg) = @_;
493	$class->SUPER::new (can_events => 0, %arg);	644	$class->SUPER::new (can_events => 0, %arg);
494	}	645	}
495		646
496	sub size_request {	647	sub size_request {
497	(0, 0)	648	my ($self) = @_;
		649
		650	($self->{w} + 0, $self->{h} + 0)
498	}	651	}
499		652
500	sub draw { }	653	sub draw { }
501		654
502	#############################################################################	655	#############################################################################
…		…
519		672
520	$self	673	$self
521	}	674	}
522		675
523	sub add {	676	sub add {
524	my ($self, $child) = @_;	677	my ($self, @widgets) = @_;
525		678
526	$child->set_parent ($self);	679	$_->set_parent ($self)
		680	for @widgets;
527		681
528	use sort 'stable';	682	use sort 'stable';
529		683
530	$self->{children} = [	684	$self->{children} = [
531	sort { $a->{z} <=> $b->{z} }	685	sort { $a->{z} <=> $b->{z} }
532	@{$self->{children}}, $child	686	@{$self->{children}}, @widgets
533	];	687	];
534		688
535	$child->check_size;	689	$self->realloc;
536	}	690	}
537		691
538	sub children {	692	sub children {
539	@{ $_[0]{children} }	693	@{ $_[0]{children} }
540	}	694	}
…		…
545	delete $child->{parent};	699	delete $child->{parent};
546	$child->hide;	700	$child->hide;
547		701
548	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];	702	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];
549		703
550	$self->check_size;	704	$self->realloc;
551	$self->update;
552	}	705	}
553		706
554	sub clear {	707	sub clear {
555	my ($self) = @_;	708	my ($self) = @_;
556		709
…		…
559		712
560	for (@$children) {	713	for (@$children) {
561	delete $_->{parent};	714	delete $_->{parent};
562	$_->hide;	715	$_->hide;
563	}	716	}
		717
		718	$self->realloc;
564	}	719	}
565		720
566	sub find_widget {	721	sub find_widget {
567	my ($self, $x, $y) = @_;	722	my ($self, $x, $y) = @_;
568		723
…		…
643	}	798	}
644		799
645	sub update {	800	sub update {
646	my ($self) = @_;	801	my ($self) = @_;
647		802
648	# we want to do this delayed...	803	$ROOT->on_post_alloc ($self => sub { $self->render_child });
649	$self->render_chld;
650	$self->SUPER::update;	804	$self->SUPER::update;
651	}
652
653	sub render_chld {
654	my ($self) = @_;
655
656	$self->{texture} = new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {
657	glClearColor 0, 0, 0, 1;
658	glClear GL_COLOR_BUFFER_BIT;
659	$self->child->draw;
660	};
661	}	805	}
662		806
663	sub size_allocate {	807	sub size_allocate {
664	my ($self, $w, $h) = @_;	808	my ($self, $w, $h) = @_;
665		809
666	$self->child->configure (0, 0, $w, $h);	810	$self->SUPER::size_allocate ($w, $h);
		811	$self->update;
		812	}
667		813
		814	sub _render {
		815	my ($self) = @_;
		816
		817	$self->{children}[0]->draw;
		818	}
		819
		820	sub render_child {
		821	my ($self) = @_;
		822
		823	$self->{texture} = new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {
		824	glClearColor 0, 0, 0, 0;
		825	glClear GL_COLOR_BUFFER_BIT;
		826
		827	{
		828	package CFClient::UI::Base;
		829
		830	($draw_x, $draw_y, $draw_w, $draw_h) =
		831	(0, 0, $self->{w}, $self->{h});
		832	}
		833
668	$self->render_chld;	834	$self->_render;
		835	};
669	}	836	}
670		837
671	sub _draw {	838	sub _draw {
672	my ($self) = @_;	839	my ($self) = @_;
673		840
674	my ($w, $h) = ($self->w, $self->h);	841	my ($w, $h) = @$self{qw(w h)};
675		842
676	my $tex = $self->{texture}	843	my $tex = $self->{texture}
677	or return;	844	or return;
678		845
679	glEnable GL_BLEND;
680	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
681	glEnable GL_TEXTURE_2D;	846	glEnable GL_TEXTURE_2D;
682	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	847	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
		848	glColor 1, 1, 1, 1;
683		849
684	$tex->draw_quad (0, 0, $w, $h);	850	$tex->draw_quad_alpha_premultiplied (0, 0, $w, $h);
685		851
686	glDisable GL_BLEND;
687	glDisable GL_TEXTURE_2D;	852	glDisable GL_TEXTURE_2D;
688	}	853	}
689		854
690	#############################################################################	855	#############################################################################
691		856
692	package CFClient::UI::ViewPort;	857	package CFClient::UI::ViewPort;
693		858
694	our @ISA = CFClient::UI::Window::;	859	our @ISA = CFClient::UI::Window::;
695
696	sub new { die }
697
698	sub size_request {
699	my ($self) = @_;
700
701	@$self{qw(child_w child_h)} = @{$self->child}{qw(req_w req_h)};
702	$self->child->size_allocate (0, 0, @$self{qw(child_w child_h)});
703
704	@$self{qw(child_w child_h)}
705	}
706
707	sub _draw {
708	my ($self) = @_;
709
710	$self->{children}[1]->draw;
711	}
712
713
714	#############################################################################
715
716	package CFClient::UI::Frame;
717
718	our @ISA = CFClient::UI::Bin::;
719
720	use CFClient::OpenGL;
721		860
722	sub new {	861	sub new {
723	my $class = shift;	862	my $class = shift;
724		863
725	my $self = $class->SUPER::new (	864	$class->SUPER::new (
726	bg => [1, 1, 1, 1],	865	scroll_x => 0,
727	border_bg => [1, 1, 1, 1],	866	scroll_y => 1,
728	border => 0.8,
729	@_	867	@_,
730	);	868	)
731
732	$self
733	}	869	}
734		870
735	sub _draw {	871	sub size_request {
		872	my ($self) = @_;
		873
		874	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
		875
		876	$w = 10 if $self->{scroll_x};
		877	$h = 10 if $self->{scroll_y};
		878
		879	($w, $h)
		880	}
		881
		882	sub size_allocate {
736	my ($self) = @_;	883	my ($self, $w, $h) = @_;
737		884
738	my ($w, $h) = ($self->{w}, $self->{h});	885	my $child = $self->child;
739		886
740	glEnable GL_BLEND;	887	$w = $child->{req_w} if $self->{scroll_x} && $child->{req_w};
741	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	888	$h = $child->{req_h} if $self->{scroll_y} && $child->{req_h};
742	glEnable GL_TEXTURE_2D;
743	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
744		889
745	# glBegin GL_QUADS;	890	$self->child->configure (0, 0, $w, $h);
746	# glColor 0, 0, 0, 0;	891	$self->update;
747	# glVertex 0 , 0;	892	}
748	# glVertex 0 , $h;
749	# glVertex $w, $h;
750	# glVertex $w, 0;
751	# glEnd;
752		893
		894	sub set_offset {
		895	my ($self, $x, $y) = @_;
753		896
754	$self->child->draw;	897	$self->{view_x} = int $x;
755	glDisable GL_BLEND;	898	$self->{view_y} = int $y;
756	glDisable GL_TEXTURE_2D;	899
		900	$self->update;
		901	}
		902
		903	# hmm, this does not work for topleft of $self... but we should not ask for that
		904	sub coord2local {
		905	my ($self, $x, $y) = @_;
		906
		907	$self->SUPER::coord2local ($x + $self->{view_x}, $y + $self->{view_y})
		908	}
		909
		910	sub coord2global {
		911	my ($self, $x, $y) = @_;
		912
		913	$x = List::Util::min $self->{w}, $x - $self->{view_x};
		914	$y = List::Util::min $self->{h}, $y - $self->{view_y};
		915
		916	$self->SUPER::coord2global ($x, $y)
		917	}
		918
		919	sub find_widget {
		920	my ($self, $x, $y) = @_;
		921
		922	if ( $x >= $self->{x} && $x < $self->{x} + $self->{w}
		923	&& $y >= $self->{y} && $y < $self->{y} + $self->{h}
		924	) {
		925	$self->child->find_widget ($x + $self->{view_x}, $y + $self->{view_y})
		926	} else {
		927	$self->CFClient::UI::Base::find_widget ($x, $y)
		928	}
		929	}
		930
		931	sub _render {
		932	my ($self) = @_;
		933
		934	local $CFClient::UI::Base::draw_x = $CFClient::UI::Base::draw_x - $self->{view_x};
		935	local $CFClient::UI::Base::draw_y = $CFClient::UI::Base::draw_y - $self->{view_y};
		936
		937	CFClient::OpenGL::glTranslate -$self->{view_x}, -$self->{view_y};
		938
		939	$self->SUPER::_render;
757	}	940	}
758		941
759	#############################################################################	942	#############################################################################
760		943
761	package CFClient::UI::FancyFrame;	944	package CFClient::UI::ScrolledWindow;
762		945
763	our @ISA = CFClient::UI::Bin::;	946	our @ISA = CFClient::UI::HBox::;
764
765	use CFClient::OpenGL;
766
767	my @tex =
768	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
769	qw(d1_bg.png d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);
770		947
771	sub new {	948	sub new {
772	my $class = shift;	949	my $class = shift;
773		950
774	# TODO: user_x, user_y, overwrite moveto?	951	my $self;
		952
		953	my $slider = new CFClient::UI::Slider
		954	vertical => 1,
		955	range => [0, 0, 1, 0.01], # HACK fix
		956	on_changed => sub {
		957	$self->{vp}->set_offset (0, $_[1]);
		958	},
		959	;
		960
		961	$self = $class->SUPER::new (
		962	vp => (new CFClient::UI::ViewPort expand => 1),
		963	slider => $slider,
		964	@_,
		965	);
		966
		967	$self->{vp}->add ($self->{scrolled});
		968	$self->add ($self->{vp});
		969	$self->add ($self->{slider});
		970
		971	$self
		972	}
		973
		974	sub update {
		975	my ($self) = @_;
		976
		977	$self->SUPER::update;
		978
		979	# todo: overwrite size_allocate of child
		980	my $child = $self->{vp}->child;
		981	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
		982	}
		983
		984	sub size_allocate {
		985	my ($self, $w, $h) = @_;
		986
		987	$self->SUPER::size_allocate ($w, $h);
		988
		989	my $child = $self->{vp}->child;
		990	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
		991	}
		992
		993	#TODO# update range on size_allocate depending on child
		994	# update viewport offset on scroll
		995
		996	#############################################################################
		997
		998	package CFClient::UI::Frame;
		999
		1000	our @ISA = CFClient::UI::Bin::;
		1001
		1002	use CFClient::OpenGL;
		1003
		1004	sub new {
		1005	my $class = shift;
		1006
		1007	$class->SUPER::new (
		1008	bg => undef,
		1009	@_,
		1010	)
		1011	}
		1012
		1013	sub _draw {
		1014	my ($self) = @_;
		1015
		1016	if ($self->{bg}) {
		1017	my ($w, $h) = @$self{qw(w h)};
		1018
		1019	glEnable GL_BLEND;
		1020	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
		1021	glColor @{ $self->{bg} };
		1022
		1023	glBegin GL_QUADS;
		1024	glVertex 0 , 0;
		1025	glVertex 0 , $h;
		1026	glVertex $w, $h;
		1027	glVertex $w, 0;
		1028	glEnd;
		1029
		1030	glDisable GL_BLEND;
		1031	}
		1032
		1033	$self->SUPER::_draw;
		1034	}
		1035
		1036	#############################################################################
		1037
		1038	package CFClient::UI::FancyFrame;
		1039
		1040	our @ISA = CFClient::UI::Bin::;
		1041
		1042	use CFClient::OpenGL;
		1043
		1044	my $bg =
		1045	new_from_file CFClient::Texture CFClient::find_rcfile "d1_bg.png",
		1046	mipmap => 1, wrap => 1;
		1047
		1048	my @border =
		1049	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
		1050	qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);
		1051
		1052	sub new {
		1053	my $class = shift;
775		1054
776	my $self = $class->SUPER::new (	1055	my $self = $class->SUPER::new (
777	bg => [1, 1, 1, 1],	1056	bg => [1, 1, 1, 1],
778	border_bg => [1, 1, 1, 1],	1057	border_bg => [1, 1, 1, 1],
779	border => 0.8,	1058	border => 0.6,
780	can_events => 1,	1059	can_events => 1,
		1060	min_w => 16,
		1061	min_h => 16,
781	@_	1062	@_
782	);	1063	);
783		1064
784	$self->{title} &&= new CFClient::UI::Label	1065	$self->{title} &&= new CFClient::UI::Label
785	align => 0,	1066	align => 0,
786	valign => 1,	1067	valign => 1,
787	text => $self->{title},	1068	text => $self->{title},
788	fontsize => 1;	1069	fontsize => $self->{border};
789		1070
790	$self	1071	$self
791	}	1072	}
792		1073
793	sub border {	1074	sub border {
…		…
809	my ($self, $w, $h) = @_;	1090	my ($self, $w, $h) = @_;
810		1091
811	$h -= List::Util::max 0, $self->border * 2;	1092	$h -= List::Util::max 0, $self->border * 2;
812	$w -= List::Util::max 0, $self->border * 2;	1093	$w -= List::Util::max 0, $self->border * 2;
813		1094
814	$self->{title}->configure ($self->border, $self->border - $::FONTSIZE * 2, $w, $::FONTSIZE * 2)	1095	$self->{title}->configure ($self->border, int $self->border - $::FONTSIZE * 2, $w, int $::FONTSIZE * 2)
815	if $self->{title};	1096	if $self->{title};
816		1097
817	$self->child->configure ($self->border, $self->border, $w, $h);	1098	$self->child->configure ($self->border, $self->border, $w, $h);
818	}	1099	}
819		1100
820	sub button_down {	1101	sub button_down {
821	my ($self, $ev, $x, $y) = @_;	1102	my ($self, $ev, $x, $y) = @_;
822		1103
		1104	my ($w, $h) = @$self{qw(w h)};
823	my $border = $self->border;	1105	my $border = $self->border;
824		1106
825	if ($x < $self->{w} && $x >= $self->{w} - $border	1107	my $lr = ($x >= 0 && $x < $border) || ($x > $w - $border && $x < $w);
826	&& $y < $self->{h} && $y >= $self->{h} - $border) {	1108	my $td = ($y >= 0 && $y < $border) || ($y > $h - $border && $y < $h);
827		1109
		1110	if ($lr & $td) {
		1111	my ($wx, $wy) = ($self->{x}, $self->{y});
828	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1112	my ($ox, $oy) = ($ev->{x}, $ev->{y});
829	my ($bw, $bh) = ($self->{w}, $self->{h});	1113	my ($bw, $bh) = ($self->{w}, $self->{h});
830		1114
		1115	my $mx = $x < $border;
		1116	my $my = $y < $border;
		1117
831	$self->{motion} = sub {	1118	$self->{motion} = sub {
832	my ($ev, $x, $y) = @_;	1119	my ($ev, $x, $y) = @_;
833		1120
834	($x, $y) = ($ev->{x}, $ev->{y});	1121	my $dx = $ev->{x} - $ox;
		1122	my $dy = $ev->{y} - $oy;
835		1123
836	$self->{user_w} = $bw + $x - $ox;	1124	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);
837	$self->{user_h} = $bh + $y - $oy;	1125	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);
838	$self->check_size;	1126
		1127	$self->realloc;
		1128	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
839	};	1129	};
840		1130
841	} elsif ($x >= 0 && $x < $self->{w}	1131	} elsif ($lr ^ $td) {
842	&& $y >= 0 && $y < $border) {
843
844	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1132	my ($ox, $oy) = ($ev->{x}, $ev->{y});
845	my ($bx, $by) = ($self->{x}, $self->{y});	1133	my ($bx, $by) = ($self->{x}, $self->{y});
846		1134
847	$self->{motion} = sub {	1135	$self->{motion} = sub {
848	my ($ev, $x, $y) = @_;	1136	my ($ev, $x, $y) = @_;
849		1137
850	($x, $y) = ($ev->{x}, $ev->{y});	1138	($x, $y) = ($ev->{x}, $ev->{y});
851		1139
852	$self->move ($bx + $x - $ox, $by + $y - $oy);	1140	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);
853	$self->update;
854	};	1141	};
855	}	1142	}
856	}	1143	}
857		1144
858	sub button_up {	1145	sub button_up {
…		…
871	my ($self) = @_;	1158	my ($self) = @_;
872		1159
873	my ($w, $h ) = ($self->{w}, $self->{h});	1160	my ($w, $h ) = ($self->{w}, $self->{h});
874	my ($cw, $ch) = ($self->child->{w}, $self->child->{h});	1161	my ($cw, $ch) = ($self->child->{w}, $self->child->{h});
875		1162
876	glEnable GL_BLEND;
877	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
878	glEnable GL_TEXTURE_2D;	1163	glEnable GL_TEXTURE_2D;
879	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;	1164	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
880		1165
881	my $border = $self->border;	1166	my $border = $self->border;
882		1167
883	glColor @{ $self->{border_bg} };	1168	glColor @{ $self->{border_bg} };
884	$tex[1]->draw_quad (0, 0, $w, $border);	1169	$border[0]->draw_quad_alpha (0, 0, $w, $border);
885	$tex[3]->draw_quad (0, $border, $border, $ch);	1170	$border[1]->draw_quad_alpha (0, $border, $border, $ch);
886	$tex[2]->draw_quad ($w - $border, $border, $border, $ch);	1171	$border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);
887	$tex[4]->draw_quad (0, $h - $border, $w, $border);	1172	$border[3]->draw_quad_alpha (0, $h - $border, $w, $border);
888		1173
889	my $bg = $tex[0];	1174	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {
		1175	glColor @{ $self->{bg} };
890		1176
891	# TODO: repeat texture not scale	1177	# TODO: repeat texture not scale
892	my $rep_x = $cw / $bg->{w};	1178	# solve this better(?)
893	my $rep_y = $ch / $bg->{h};	1179	$bg->{s} = $cw / $bg->{w};
894		1180	$bg->{t} = $ch / $bg->{h};
895	glColor @{ $self->{bg} };
896
897	$bg->{s} = $rep_x;
898	$bg->{t} = $rep_y;
899	$bg->{wrap_mode} = 1;
900	$bg->draw_quad ($border, $border, $cw, $ch);	1181	$bg->draw_quad_alpha ($border, $border, $cw, $ch);
		1182	}
901		1183
902	glDisable GL_TEXTURE_2D;	1184	glDisable GL_TEXTURE_2D;
903	glDisable GL_BLEND;
904		1185
905	$self->{title}->draw if $self->{title};	1186	$self->{title}->draw if $self->{title};
		1187
906	$self->child->draw;	1188	$self->child->draw;
907	}	1189	}
908		1190
909	#############################################################################	1191	#############################################################################
910		1192
…		…
919	sub new {	1201	sub new {
920	my $class = shift;	1202	my $class = shift;
921		1203
922	$class->SUPER::new (	1204	$class->SUPER::new (
923	col_expand => [],	1205	col_expand => [],
924	@_	1206	@_,
925	)	1207	)
		1208	}
		1209
		1210	sub children {
		1211	grep $_, map @$_, grep $_, @{ $_[0]{children} }
926	}	1212	}
927		1213
928	sub add {	1214	sub add {
929	my ($self, $x, $y, $child) = @_;	1215	my ($self, $x, $y, $child) = @_;
930		1216
931	$child->set_parent ($self);	1217	$child->set_parent ($self);
932	$self->{children}[$y][$x] = $child;	1218	$self->{children}[$y][$x] = $child;
933		1219
934	$child->check_size;	1220	$self->realloc;
935	}	1221	}
936		1222
937	sub children {
938	grep $_, map @$_, grep $_, @{ $_[0]{children} }
939	}
940
941	# TODO: move to container class maybe? send childs a signal on removal?	1223	# TODO: move to container class maybe? send children a signal on removal?
942	sub clear {	1224	sub clear {
943	my ($self) = @_;	1225	my ($self) = @_;
944		1226
945	my @children = $self->children;	1227	my @children = $self->children;
946	delete $self->{children};	1228	delete $self->{children};
…		…
948	for (@children) {	1230	for (@children) {
949	delete $_->{parent};	1231	delete $_->{parent};
950	$_->hide;	1232	$_->hide;
951	}	1233	}
952		1234
953	$self->update;	1235	$self->realloc;
954	}	1236	}
955		1237
956	sub get_wh {	1238	sub get_wh {
957	my ($self) = @_;	1239	my ($self) = @_;
958		1240
…		…
989	sub size_allocate {	1271	sub size_allocate {
990	my ($self, $w, $h) = @_;	1272	my ($self, $w, $h) = @_;
991		1273
992	my ($ws, $hs) = $self->get_wh;	1274	my ($ws, $hs) = $self->get_wh;
993		1275
994	my $req_w = sum @$ws;	1276	my $req_w = (sum @$ws) || 1;
995	my $req_h = sum @$hs;	1277	my $req_h = (sum @$hs) || 1;
996		1278
997	# TODO: nicer code && do row_expand	1279	# TODO: nicer code && do row_expand
998	my @col_expand = @{$self->{col_expand}};	1280	my @col_expand = @{$self->{col_expand}};
999	@col_expand = (1) x @$ws unless @col_expand;	1281	@col_expand = (1) x @$ws unless @col_expand;
1000	my $col_expand = (sum @col_expand) || 1;	1282	my $col_expand = (sum @col_expand) || 1;
…		…
1054	}	1336	}
1055	}	1337	}
1056		1338
1057	#############################################################################	1339	#############################################################################
1058		1340
1059	package CFClient::UI::HBox;	1341	package CFClient::UI::Box;
1060
1061	# TODO: wrap into common Box base class
1062		1342
1063	our @ISA = CFClient::UI::Container::;	1343	our @ISA = CFClient::UI::Container::;
1064		1344
1065	sub size_request {	1345	sub size_request {
1066	my ($self) = @_;	1346	my ($self) = @_;
1067		1347
1068	my @alloc = map [$_->size_request], @{$self->{children}};	1348	$self->{vertical}
1069		1349	? (
1070	(	1350	(List::Util::max map $_->{req_w}, @{$self->{children}}),
1071	(List::Util::sum map $_->[0], @alloc),	1351	(List::Util::sum map $_->{req_h}, @{$self->{children}}),
1072	(List::Util::max map $_->[1], @alloc),	1352	)
1073	)	1353	: (
		1354	(List::Util::sum map $_->{req_w}, @{$self->{children}}),
		1355	(List::Util::max map $_->{req_h}, @{$self->{children}}),
		1356	)
1074	}	1357	}
1075		1358
1076	sub size_allocate {	1359	sub size_allocate {
1077	my ($self, $w, $h) = @_;	1360	my ($self, $w, $h) = @_;
1078		1361
1079	($h, $w) = ($w, $h);	1362	my $space = $self->{vertical} ? $h : $w;
1080
1081	my $children = $self->{children};	1363	my $children = $self->{children};
1082		1364
1083	my @h = map $_->{req_w}, @$children;	1365	my @req;
1084		1366
1085	my $req_h = List::Util::sum @h;	1367	if ($self->{homogeneous}) {
1086		1368	@req = ($space / (@$children || 1)) x @$children;
1087	if ($req_h > $h) {
1088	# ah well, not enough space
1089	$_ *= $h / $req_h for @h;
1090	} else {	1369	} else {
		1370	@req = map $_->{$self->{vertical} ? "req_h" : "req_w"}, @$children;
		1371	my $req = List::Util::sum @req;
		1372
		1373	if ($req > $space) {
		1374	# ah well, not enough space
		1375	$_ *= $space / $req for @req;
		1376	} else {
1091	my $exp = List::Util::sum map $_->{expand}, @$children;	1377	my $expand = (List::Util::sum map $_->{expand}, @$children) || 1;
1092	$exp ||= 1;
1093		1378
		1379	$space = ($space - $req) / $expand; # remaining space to give away
		1380
		1381	$req[$_] += $space * $children->[$_]{expand}
1094	for (0 .. $#$children) {	1382	for 0 .. $#$children;
1095	my $child = $children->[$_];
1096
1097	my $alloc_h = $h[$_];
1098	$alloc_h += ($h - $req_h) * $child->{expand} / $exp;
1099	$h[$_] = $alloc_h;
1100	}	1383	}
1101	}	1384	}
1102		1385
1103	CFClient::UI::harmonize \@h;	1386	CFClient::UI::harmonize \@req;
1104		1387
1105	my $y = 0;	1388	my $pos = 0;
1106	for (0 .. $#$children) {	1389	for (0 .. $#$children) {
1107	my $child = $children->[$_];
1108	my $h = $h[$_];	1390	my $alloc = $req[$_];
1109	$child->configure ($y, 0, $h, $w);	1391	$children->[$_]->configure ($self->{vertical} ? (0, $pos, $w, $alloc) : ($pos, 0, $alloc, $h));
1110		1392
1111	$y += $h;	1393	$pos += $alloc;
1112	}	1394	}
1113		1395
1114	1	1396	1
1115	}	1397	}
1116		1398
1117	#############################################################################	1399	#############################################################################
1118		1400
		1401	package CFClient::UI::HBox;
		1402
		1403	our @ISA = CFClient::UI::Box::;
		1404
		1405	sub new {
		1406	my $class = shift;
		1407
		1408	$class->SUPER::new (
		1409	vertical => 0,
		1410	@_,
		1411	)
		1412	}
		1413
		1414	#############################################################################
		1415
1119	package CFClient::UI::VBox;	1416	package CFClient::UI::VBox;
1120		1417
1121	# TODO: wrap into common Box base class
1122
1123	our @ISA = CFClient::UI::Container::;	1418	our @ISA = CFClient::UI::Box::;
1124		1419
1125	sub size_request {	1420	sub new {
1126	my ($self) = @_;	1421	my $class = shift;
1127		1422
1128	my @alloc = map [$_->size_request], @{$self->{children}};	1423	$class->SUPER::new (
1129		1424	vertical => 1,
1130	(	1425	@_,
1131	(List::Util::max map $_->[0], @alloc),
1132	(List::Util::sum map $_->[1], @alloc),
1133	)	1426	)
1134	}	1427	}
1135		1428
1136	sub size_allocate {
1137	my ($self, $w, $h) = @_;
1138
1139	my $children = $self->{children};
1140
1141	my @h = map $_->{req_h}, @$children;
1142
1143	my $req_h = List::Util::sum @h;
1144
1145	if ($req_h > $h) {
1146	# ah well, not enough space
1147	$_ *= $h / $req_h for @h;
1148	} else {
1149	my $exp = List::Util::sum map $_->{expand}, @$children;
1150	$exp ||= 1;
1151
1152	for (0 .. $#$children) {
1153	my $child = $children->[$_];
1154
1155	$h[$_] += ($h - $req_h) * $child->{expand} / $exp;
1156	}
1157	}
1158
1159	CFClient::UI::harmonize \@h;
1160
1161	my $y = 0;
1162	for (0 .. $#$children) {
1163	my $child = $children->[$_];
1164	my $h = $h[$_];
1165	$child->configure (0, $y, $w, $h);
1166
1167	$y += $h;
1168	}
1169
1170	1
1171	}
1172
1173	#############################################################################	1429	#############################################################################
1174		1430
1175	package CFClient::UI::Label;	1431	package CFClient::UI::Label;
1176		1432
1177	our @ISA = CFClient::UI::Base::;	1433	our @ISA = CFClient::UI::DrawBG::;
1178		1434
1179	use CFClient::OpenGL;	1435	use CFClient::OpenGL;
1180		1436
1181	sub new {	1437	sub new {
1182	my ($class, %arg) = @_;	1438	my ($class, %arg) = @_;
1183		1439
1184	my $self = $class->SUPER::new (	1440	my $self = $class->SUPER::new (
1185	fg => [1, 1, 1],	1441	fg => [1, 1, 1],
		1442	#bg => none
		1443	#active_bg => none
1186	#font => default_font	1444	#font => default_font
		1445	#text => initial text
		1446	#markup => initial narkup
		1447	#max_w => maximum pixel width
		1448	ellipsise => 3, # end
		1449	layout => (new CFClient::Layout),
1187	fontsize => 1,	1450	fontsize => 1,
1188	text => "",
1189	align => -1,	1451	align => -1,
1190	valign => -1,	1452	valign => -1,
1191	padding => 2,	1453	padding_x => 2,
1192	layout => new CFClient::Layout,	1454	padding_y => 2,
1193	can_events => 0,	1455	can_events => 0,
1194	%arg	1456	%arg
1195	);	1457	);
1196		1458
1197	if (exists $self->{template}) {	1459	if (exists $self->{template}) {
1198	my $layout = new CFClient::Layout;	1460	my $layout = new CFClient::Layout;
1199	$layout->set_text (delete $self->{template});	1461	$layout->set_text (delete $self->{template});
1200	$self->{template} = $layout;	1462	$self->{template} = $layout;
1201	}	1463	}
1202		1464
1203	$self->set_text (delete $self->{text}) if exists $self->{text};	1465	if (exists $self->{markup}) {
1204	$self->set_markup (delete $self->{markup}) if exists $self->{markup};	1466	$self->set_markup (delete $self->{markup});
		1467	} else {
		1468	$self->set_text (delete $self->{text});
		1469	}
1205		1470
1206	$self	1471	$self
1207	}	1472	}
1208		1473
1209	sub escape {	1474	sub escape($) {
1210	local $_ = $_[1];	1475	local $_ = $_[0];
1211		1476
1212	s/&/&amp;/g;	1477	s/&/&amp;/g;
1213	s/>/&gt;/g;	1478	s/>/&gt;/g;
1214	s/</&lt;/g;	1479	s/</&lt;/g;
1215		1480
1216	$_[1]	1481	$_
1217	}	1482	}
1218		1483
1219	sub update {	1484	sub update {
1220	my ($self) = @_;	1485	my ($self) = @_;
1221		1486
1222	delete $self->{texture};	1487	delete $self->{texture};
1223	$self->SUPER::update;	1488	$self->SUPER::update;
1224	}	1489	}
1225		1490
1226	sub reconfigure {
1227	my ($self) = @_;
1228
1229	delete $self->{texture};
1230	}
1231
1232	sub set_text {	1491	sub set_text {
1233	my ($self, $text) = @_;	1492	my ($self, $text) = @_;
1234		1493
1235	return if $self->{text} eq "T$text";	1494	return if $self->{text} eq "T$text";
1236	$self->{text} = "T$text";	1495	$self->{text} = "T$text";
1237		1496
		1497	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;
1238	$self->{layout}->set_text ($text);	1498	$self->{layout}->set_text ($text);
1239		1499
1240	delete $self->{texture};	1500	$self->realloc;
1241	$self->update;	1501	$self->update;
1242	$self->check_size;
1243	}	1502	}
1244		1503
1245	sub set_markup {	1504	sub set_markup {
1246	my ($self, $markup) = @_;	1505	my ($self, $markup) = @_;
1247		1506
1248	return if $self->{text} eq "M$markup";	1507	return if $self->{text} eq "M$markup";
1249	$self->{text} = "M$markup";	1508	$self->{text} = "M$markup";
1250		1509
		1510	my $rgba = $markup =~ /span.*(?:foreground|background)/;
		1511
		1512	$self->{layout} = new CFClient::Layout $rgba if $self->{layout}->is_rgba != $rgba;
1251	$self->{layout}->set_markup ($markup);	1513	$self->{layout}->set_markup ($markup);
1252		1514
1253	delete $self->{texture};	1515	$self->realloc;
1254	$self->update;	1516	$self->update;
1255	$self->check_size;
1256	}	1517	}
1257		1518
1258	sub size_request {	1519	sub size_request {
1259	my ($self) = @_;	1520	my ($self) = @_;
1260		1521
1261	$self->{layout}->set_font ($self->{font}) if $self->{font};	1522	$self->{layout}->set_font ($self->{font}) if $self->{font};
1262	$self->{layout}->set_width ($self->{max_w} || -1);	1523	$self->{layout}->set_width ($self->{max_w} || -1);
		1524	$self->{layout}->set_ellipsise ($self->{ellipsise});
		1525	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1263	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1526	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1264		1527
1265	my ($w, $h) = $self->{layout}->size;	1528	my ($w, $h) = $self->{layout}->size;
1266		1529
1267	if (exists $self->{template}) {	1530	if (exists $self->{template}) {
…		…
1272		1535
1273	$w = List::Util::max $w, $w2;	1536	$w = List::Util::max $w, $w2;
1274	$h = List::Util::max $h, $h2;	1537	$h = List::Util::max $h, $h2;
1275	}	1538	}
1276		1539
1277	(	1540	($w, $h)
1278	$w + $self->{padding} * 2,
1279	$h + $self->{padding} * 2,
1280	)
1281	}	1541	}
1282		1542
1283	sub size_allocate {	1543	sub size_allocate {
1284	my ($self, $w, $h) = @_;	1544	my ($self, $w, $h) = @_;
1285		1545
1286	delete $self->{texture};	1546	delete $self->{texture}
		1547	unless $w >= $self->{req_w} && $self->{old_w} >= $self->{req_w};
1287	}	1548	}
1288		1549
1289	sub set_fontsize {	1550	sub set_fontsize {
1290	my ($self, $fontsize) = @_;	1551	my ($self, $fontsize) = @_;
1291		1552
1292	$self->{fontsize} = $fontsize;	1553	$self->{fontsize} = $fontsize;
1293	delete $self->{texture};	1554	delete $self->{texture};
1294	$self->check_size;	1555
1295	$self->update;	1556	$self->realloc;
1296	}	1557	}
1297		1558
1298	sub _draw {	1559	sub _draw {
1299	my ($self) = @_;	1560	my ($self) = @_;
1300		1561
		1562	$self->SUPER::_draw; # draw background, if applicable
		1563
1301	my $tex = $self->{texture} ||= do {	1564	my $tex = $self->{texture} ||= do {
		1565	$self->{layout}->set_foreground (@{$self->{fg}});
1302	$self->{layout}->set_font ($self->{font}) if $self->{font};	1566	$self->{layout}->set_font ($self->{font}) if $self->{font};
1303	$self->{layout}->set_width ($self->{w});	1567	$self->{layout}->set_width ($self->{w});
		1568	$self->{layout}->set_ellipsise ($self->{ellipsise});
		1569	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1304	$self->{layout}->set_height (List::Util::min $self->{h}, $self->{fontsize} * $::FONTSIZE);	1570	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
		1571
1305	new_from_layout CFClient::Texture $self->{layout}	1572	my $tex = new_from_layout CFClient::Texture $self->{layout};
		1573
		1574	$self->{ox} = int ($self->{align} < 0 ? $self->{padding_x}
		1575	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding_x}
		1576	: ($self->{w} - $tex->{w}) * 0.5);
		1577
		1578	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding_y}
		1579	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding_y}
		1580	: ($self->{h} - $tex->{h}) * 0.5);
		1581
		1582	$tex
1306	};	1583	};
1307		1584
1308	glEnable GL_BLEND;
1309	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1310	glEnable GL_TEXTURE_2D;	1585	glEnable GL_TEXTURE_2D;
1311	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1586	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1312		1587
		1588	if ($tex->{format} == GL_ALPHA) {
1313	glColor @{$self->{fg}};	1589	glColor @{$self->{fg}};
1314
1315	$self->{ox} = int (
1316	$self->{align} < 0 ? $self->{padding}
1317	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding}
1318	: ($self->{w} - $tex->{w}) * 0.5
1319	);
1320
1321	$self->{oy} = int (
1322	$self->{valign} < 0 ? $self->{padding}
1323	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding}
1324	: ($self->{h} - $tex->{h}) * 0.5
1325	);
1326
1327	$tex->draw_quad ($self->{ox}, $self->{oy});	1590	$tex->draw_quad_alpha ($self->{ox}, $self->{oy});
		1591	} else {
		1592	$tex->draw_quad_alpha_premultiplied ($self->{ox}, $self->{oy});
		1593	}
1328		1594
1329	glDisable GL_TEXTURE_2D;	1595	glDisable GL_TEXTURE_2D;
1330	glDisable GL_BLEND;
1331	}	1596	}
1332		1597
1333	#############################################################################	1598	#############################################################################
1334		1599
1335	package CFClient::UI::EntryBase;	1600	package CFClient::UI::EntryBase;
…		…
1348	active_fg => [0, 0, 0],	1613	active_fg => [0, 0, 0],
1349	can_hover => 1,	1614	can_hover => 1,
1350	can_focus => 1,	1615	can_focus => 1,
1351	valign => 0,	1616	valign => 0,
1352	can_events => 1,	1617	can_events => 1,
		1618	#text => ...
1353	@_	1619	@_
1354	)	1620	)
1355	}	1621	}
1356		1622
1357	sub _set_text {	1623	sub _set_text {
…		…
1367	$self->{text} = $text;	1633	$self->{text} = $text;
1368		1634
1369	$text =~ s/./*/g if $self->{hidden};	1635	$text =~ s/./*/g if $self->{hidden};
1370	$self->{layout}->set_text ("$text ");	1636	$self->{layout}->set_text ("$text ");
1371		1637
1372	$self->emit (changed => $self->{text});	1638	$self->_emit (changed => $self->{text});
		1639	}
		1640
		1641	sub set_text {
		1642	my ($self, $text) = @_;
		1643
		1644	$self->{cursor} = length $text;
		1645	$self->_set_text ($text);
		1646
		1647	$self->realloc;
1373	}	1648	}
1374		1649
1375	sub get_text {	1650	sub get_text {
1376	$_[0]{text}	1651	$_[0]{text}
1377	}	1652	}
…		…
1380	my ($self) = @_;	1655	my ($self) = @_;
1381		1656
1382	my ($w, $h) = $self->SUPER::size_request;	1657	my ($w, $h) = $self->SUPER::size_request;
1383		1658
1384	($w + 1, $h) # add 1 for cursor	1659	($w + 1, $h) # add 1 for cursor
1385	}
1386
1387	sub size_allocate {
1388	my ($self, $w, $h) = @_;
1389
1390	$self->_set_text (delete $self->{text});#d# don't check for == inside _set_text
1391	}
1392
1393	sub set_text {
1394	my ($self, $text) = @_;
1395
1396	$self->{cursor} = length $text;
1397	$self->_set_text ($text);
1398	$self->update;
1399	}	1660	}
1400		1661
1401	sub key_down {	1662	sub key_down {
1402	my ($self, $ev) = @_;	1663	my ($self, $ev) = @_;
1403		1664
…		…
1405	my $sym = $ev->{sym};	1666	my $sym = $ev->{sym};
1406	my $uni = $ev->{unicode};	1667	my $uni = $ev->{unicode};
1407		1668
1408	my $text = $self->get_text;	1669	my $text = $self->get_text;
1409		1670
1410	if ($sym == 8) {	1671	if ($uni == 8) {
1411	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};	1672	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};
1412	} elsif ($sym == 127) {	1673	} elsif ($uni == 127) {
1413	substr $text, $self->{cursor}, 1, "";	1674	substr $text, $self->{cursor}, 1, "";
1414	} elsif ($sym == CFClient::SDLK_LEFT) {	1675	} elsif ($sym == CFClient::SDLK_LEFT) {
1415	--$self->{cursor} if $self->{cursor};	1676	--$self->{cursor} if $self->{cursor};
1416	} elsif ($sym == CFClient::SDLK_RIGHT) {	1677	} elsif ($sym == CFClient::SDLK_RIGHT) {
1417	++$self->{cursor} if $self->{cursor} < length $self->{text};	1678	++$self->{cursor} if $self->{cursor} < length $self->{text};
1418	} elsif ($sym == CFClient::SDLK_HOME) {	1679	} elsif ($sym == CFClient::SDLK_HOME) {
1419	$self->{cursor} = 0;	1680	$self->{cursor} = 0;
1420	} elsif ($sym == CFClient::SDLK_END) {	1681	} elsif ($sym == CFClient::SDLK_END) {
1421	$self->{cursor} = length $text;	1682	$self->{cursor} = length $text;
1422	} elsif ($sym == 27) {	1683	} elsif ($uni == 27) {
1423	$self->emit ('escape');	1684	$self->_emit ('escape');
1424	} elsif ($uni) {	1685	} elsif ($uni) {
1425	substr $text, $self->{cursor}++, 0, chr $uni;	1686	substr $text, $self->{cursor}++, 0, chr $uni;
1426	}	1687	}
1427		1688
1428	$self->_set_text ($text);	1689	$self->_set_text ($text);
1429	$self->update;	1690
		1691	$self->realloc;
1430	}	1692	}
1431		1693
1432	sub focus_in {	1694	sub focus_in {
1433	my ($self) = @_;	1695	my ($self) = @_;
1434		1696
…		…
1514	if ($sym == 13) {	1776	if ($sym == 13) {
1515	unshift @{$self->{history}},	1777	unshift @{$self->{history}},
1516	my $txt = $self->get_text;	1778	my $txt = $self->get_text;
1517	$self->{history_pointer} = -1;	1779	$self->{history_pointer} = -1;
1518	$self->{history_saveback} = '';	1780	$self->{history_saveback} = '';
1519	$self->emit (activate => $txt);	1781	$self->_emit (activate => $txt);
1520	$self->update;	1782	$self->update;
1521		1783
1522	} elsif ($sym == CFClient::SDLK_UP) {	1784	} elsif ($sym == CFClient::SDLK_UP) {
1523	if ($self->{history_pointer} < 0) {	1785	if ($self->{history_pointer} < 0) {
1524	$self->{history_saveback} = $self->get_text;	1786	$self->{history_saveback} = $self->get_text;
…		…
1561		1823
1562	sub new {	1824	sub new {
1563	my $class = shift;	1825	my $class = shift;
1564		1826
1565	$class->SUPER::new (	1827	$class->SUPER::new (
1566	padding => 4,	1828	padding_x => 4,
		1829	padding_y => 4,
1567	fg => [1, 1, 1],	1830	fg => [1, 1, 1],
1568	bg => [1, 1, 1, 0.2],
1569	active_fg => [0, 0, 1],	1831	active_fg => [0, 0, 1],
1570	can_hover => 1,	1832	can_hover => 1,
1571	align => 0,	1833	align => 0,
1572	valign => 0,	1834	valign => 0,
1573	can_events => 1,	1835	can_events => 1,
1574	@_	1836	@_
1575	)	1837	)
1576	}	1838	}
1577		1839
		1840	sub activate { }
		1841
1578	sub button_up {	1842	sub button_up {
1579	my ($self, $ev, $x, $y) = @_;	1843	my ($self, $ev, $x, $y) = @_;
1580		1844
		1845	$self->emit ("activate")
1581	if ($x >= 0 && $x < $self->{w}	1846	if $x >= 0 && $x < $self->{w}
1582	&& $y >= 0 && $y < $self->{h}) {	1847	&& $y >= 0 && $y < $self->{h};
1583	$self->emit ("activate");
1584	}
1585	}	1848	}
1586		1849
1587	sub _draw {	1850	sub _draw {
1588	my ($self) = @_;	1851	my ($self) = @_;
1589		1852
…		…
1591		1854
1592	if ($GRAB == $self) {	1855	if ($GRAB == $self) {
1593	$self->{fg} = $self->{active_fg};	1856	$self->{fg} = $self->{active_fg};
1594	}	1857	}
1595		1858
1596	glEnable GL_BLEND;
1597	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1598	glEnable GL_TEXTURE_2D;	1859	glEnable GL_TEXTURE_2D;
1599	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1860	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1600	glColor 0, 0, 0, 1;	1861	glColor 0, 0, 0, 1;
1601		1862
1602	$tex[0]->draw_quad (0, 0, $self->{w}, $self->{h});	1863	$tex[0]->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
1603		1864
1604	glDisable GL_TEXTURE_2D;	1865	glDisable GL_TEXTURE_2D;
1605	glDisable GL_BLEND;
1606		1866
1607	$self->SUPER::_draw;	1867	$self->SUPER::_draw;
1608	}	1868	}
1609		1869
1610	#############################################################################	1870	#############################################################################
…		…
1621		1881
1622	sub new {	1882	sub new {
1623	my $class = shift;	1883	my $class = shift;
1624		1884
1625	$class->SUPER::new (	1885	$class->SUPER::new (
1626	padding => 2,	1886	padding_x => 2,
		1887	padding_y => 2,
1627	fg => [1, 1, 1],	1888	fg => [1, 1, 1],
1628	active_fg => [1, 1, 0],	1889	active_fg => [1, 1, 0],
		1890	bg => [0, 0, 0, 0.2],
		1891	active_bg => [1, 1, 1, 0.5],
1629	state => 0,	1892	state => 0,
1630	can_hover => 1,	1893	can_hover => 1,
1631	@_	1894	@_
1632	)	1895	)
1633	}	1896	}
1634		1897
1635	sub size_request {	1898	sub size_request {
1636	my ($self) = @_;	1899	my ($self) = @_;
1637		1900
1638	($self->{padding} * 2 + 6) x 2	1901	(6) x 2
1639	}	1902	}
1640		1903
1641	sub button_down {	1904	sub button_down {
1642	my ($self, $ev, $x, $y) = @_;	1905	my ($self, $ev, $x, $y) = @_;
1643		1906
1644	if ($x >= $self->{padding} && $x < $self->{w} - $self->{padding}	1907	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1645	&& $y >= $self->{padding} && $y < $self->{h} - $self->{padding}) {	1908	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1646	$self->{state} = !$self->{state};	1909	$self->{state} = !$self->{state};
1647	$self->emit (changed => $self->{state});	1910	$self->_emit (changed => $self->{state});
1648	}	1911	}
1649	}	1912	}
1650		1913
1651	sub _draw {	1914	sub _draw {
1652	my ($self) = @_;	1915	my ($self) = @_;
1653		1916
1654	$self->SUPER::_draw;	1917	$self->SUPER::_draw;
1655		1918
1656	glTranslate $self->{padding} + 0.375, $self->{padding} + 0.375, 0;	1919	glTranslate $self->{padding_x} + 0.375, $self->{padding_y} + 0.375, 0;
1657		1920
1658	my $s = (List::Util::min @$self{qw(w h)}) - $self->{padding} * 2;	1921	my ($w, $h) = @$self{qw(w h)};
		1922
		1923	my $s = List::Util::min $w - $self->{padding_x} * 2, $h - $self->{padding_y} * 2;
1659		1924
1660	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };	1925	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };
1661		1926
1662	glEnable GL_BLEND;	1927	my $tex = $self->{state} ? $tex[1] : $tex[0];
		1928
1663	glEnable GL_TEXTURE_2D;	1929	glEnable GL_TEXTURE_2D;
1664	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1665
1666	my $tex = $self->{state} ? $tex[1] : $tex[0];
1667
1668	$tex->draw_quad (0, 0, $s, $s);	1930	$tex->draw_quad_alpha (0, 0, $s, $s);
1669
1670	glDisable GL_TEXTURE_2D;	1931	glDisable GL_TEXTURE_2D;
1671	glDisable GL_BLEND;
1672	}	1932	}
1673		1933
1674	#############################################################################	1934	#############################################################################
1675		1935
1676	package CFClient::UI::Image;	1936	package CFClient::UI::Image;
…		…
1719	glTranslate 0, -$self->{w}, 0;	1979	glTranslate 0, -$self->{w}, 0;
1720		1980
1721	($w, $h) = ($h, $w);	1981	($w, $h) = ($h, $w);
1722	}	1982	}
1723		1983
1724	glEnable GL_BLEND;
1725	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
1726	glEnable GL_TEXTURE_2D;	1984	glEnable GL_TEXTURE_2D;
1727	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1985	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1728		1986
1729	$tex->draw_quad (0, 0, $w, $h);	1987	$tex->draw_quad_alpha (0, 0, $w, $h);
1730		1988
1731	glDisable GL_BLEND;
1732	glDisable GL_TEXTURE_2D;	1989	glDisable GL_TEXTURE_2D;
1733	}	1990	}
1734		1991
1735	#############################################################################	1992	#############################################################################
1736		1993
…		…
1925	qw(s1_slider.png s1_slider_bg.png);	2182	qw(s1_slider.png s1_slider_bg.png);
1926		2183
1927	sub new {	2184	sub new {
1928	my $class = shift;	2185	my $class = shift;
1929		2186
1930	# range [value, low, high, page]	2187	# range [value, low, high, page, unit]
1931		2188
1932	# TODO: 0-width page	2189	# TODO: 0-width page
1933	# TODO: req_w/h are wrong with vertical	2190	# TODO: req_w/h are wrong with vertical
1934	# TODO: calculations are off	2191	# TODO: calculations are off
1935	my $self = $class->SUPER::new (	2192	my $self = $class->SUPER::new (
1936	fg => [1, 1, 1],	2193	fg => [1, 1, 1],
1937	active_fg => [0, 0, 0],	2194	active_fg => [0, 0, 0],
		2195	bg => [0, 0, 0, 0.2],
		2196	active_bg => [1, 1, 1, 0.5],
1938	range => [0, 0, 100, 10],	2197	range => [0, 0, 100, 10, 0],
1939	req_w => 20,	2198	min_w => $::WIDTH / 80,
1940	req_h => 20,	2199	min_h => $::WIDTH / 80,
1941	vertical => 0,	2200	vertical => 0,
1942	can_hover => 1,	2201	can_hover => 1,
1943	inner_pad => 5,	2202	inner_pad => 0.02,
1944	@_	2203	@_
1945	);	2204	);
1946		2205
		2206	$self->set_value ($self->{range}[0]);
		2207	$self->update;
		2208
1947	$self	2209	$self
1948	}	2210	}
1949		2211
		2212	sub changed { }
		2213
		2214	sub set_range {
		2215	my ($self, $range) = @_;
		2216
		2217	($range, $self->{range}) = ($self->{range}, $range);
		2218
		2219	$self->update
		2220	if "@$range" ne "@{$self->{range}}";
		2221	}
		2222
		2223	sub set_value {
		2224	my ($self, $value) = @_;
		2225
		2226	my ($old_value, $lo, $hi, $page, $unit) = @{$self->{range}};
		2227
		2228	$hi = $lo + 1 if $hi <= $lo;
		2229
		2230	$page = $hi - $lo if $page > $hi - $lo;
		2231
		2232	$value = $lo if $value < $lo;
		2233	$value = $hi - $page if $value > $hi - $page;
		2234
		2235	$value = $lo + $unit * int +($value - $lo + $unit * 0.5) / $unit
		2236	if $unit;
		2237
		2238	@{$self->{range}} = ($value, $lo, $hi, $page, $unit);
		2239
		2240	if ($value != $old_value) {
		2241	$self->_emit (changed => $value);
		2242	$self->update;
		2243	}
		2244	}
		2245
1950	sub size_request {	2246	sub size_request {
1951	my ($self) = @_;	2247	my ($self) = @_;
1952		2248
1953	my $w = $self->{req_w};	2249	($self->{req_w}, $self->{req_h})
1954	my $h = $self->{req_h};
1955
1956	$self->{vertical} ? ($h, $w) : ($w, $h)
1957	}	2250	}
1958		2251
1959	sub button_down {	2252	sub button_down {
1960	my ($self, $ev, $x, $y) = @_;	2253	my ($self, $ev, $x, $y) = @_;
1961		2254
1962	$self->SUPER::button_down ($ev, $x, $y);	2255	$self->SUPER::button_down ($ev, $x, $y);
		2256
		2257	$self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x];
		2258
1963	$self->mouse_motion ($ev, $x, $y);	2259	$self->mouse_motion ($ev, $x, $y);
1964	}	2260	}
1965		2261
1966	sub mouse_motion {	2262	sub mouse_motion {
1967	my ($self, $ev, $x, $y) = @_;	2263	my ($self, $ev, $x, $y) = @_;
1968		2264
1969	if ($GRAB == $self) {	2265	if ($GRAB == $self) {
		2266	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});
		2267
		2268	my (undef, $lo, $hi, $page) = @{$self->{range}};
		2269
		2270	$x = ($x - $self->{click}[1]) / ($w * $self->{scale});
		2271
		2272	$self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo));
		2273	}
		2274	}
		2275
		2276	sub update {
		2277	my ($self) = @_;
		2278
		2279	$CFClient::UI::ROOT->on_post_alloc ($self => sub {
		2280	$self->set_value ($self->{range}[0]);
		2281
1970	my ($value, $lo, $hi, $page) = @{$self->{range}};	2282	my ($value, $lo, $hi, $page) = @{$self->{range}};
		2283	my $range = ($hi - $page - $lo) || 1e-100;
1971		2284
1972	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});	2285	my $knob_w = List::Util::min 1, $page / ($hi - $lo) || 0.1;
1973		2286
1974	my $inner_pad_px = $self->_calc_inner_pad_px ($w);	2287	$self->{offset} = List::Util::max $self->{inner_pad}, $knob_w * 0.5;
1975	my $inner_w = $w - $inner_pad_px * 2; # * 2 for left & right	2288	$self->{scale} = 1 - 2 * $self->{offset} || 1e-100;
1976		2289
1977	$x -= $inner_pad_px; # substract the padding	2290	$value = ($value - $lo) / $range;
1978	$x = $x * ($hi - $lo) / $inner_w + $lo;	2291	$value = $value * $self->{scale} + $self->{offset};
1979	$x = $lo if $x < $lo;
1980	$x = $hi - $page if $x > $hi - $page;
1981	$self->{range}[0] = $x;
1982		2292
1983	$self->emit (changed => $x);	2293	$self->{knob_x} = $value - $knob_w * 0.5;
1984	$self->update;	2294	$self->{knob_w} = $knob_w;
1985	}	2295	});
1986	}
1987		2296
1988	# the inner_* stuff is for generating a padding for the slider handle,	2297	$self->SUPER::update;
1989	# so that the handle doesn't leave the texture. This calculation isn't 100%
1990	# correct propably, but it does the job for now
1991	sub _calc_inner_pad_px {
1992	my ($self, $w) = @_;
1993	($w / 100) * $self->{inner_pad} # % to pixels
1994	}	2298	}
1995		2299
1996	sub _draw {	2300	sub _draw {
1997	my ($self) = @_;	2301	my ($self) = @_;
1998		2302
1999	$self->SUPER::_draw ();	2303	$self->SUPER::_draw ();
2000		2304
2001	my ($w, $h) = @$self{qw(w h)};	2305	glScale $self->{w}, $self->{h};
2002		2306
2003	if ($self->{vertical}) {	2307	if ($self->{vertical}) {
2004	# draw a vertical slider like a rotated horizontal slider	2308	# draw a vertical slider like a rotated horizontal slider
2005		2309
		2310	glTranslate 1, 0, 0;
2006	glRotate 90, 0, 0, 1;	2311	glRotate 90, 0, 0, 1;
2007	glTranslate 0, -$self->{w}, 0;
2008
2009	($w, $h) = ($h, $w);
2010	}	2312	}
2011		2313
2012	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};	2314	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};
2013	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};	2315	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};
2014		2316
2015	my ($value, $lo, $hi, $page) = @{$self->{range}};
2016
2017	$hi = $value + 1 if $lo == $hi;
2018
2019	my $inner_pad_px = $self->_calc_inner_pad_px ($w);
2020	my $inner_w = $w - $inner_pad_px * 2; # * 2 for left & right
2021
2022	$page = int $page * $inner_w / ($hi - $lo);
2023	$value = int +($value - $lo) * $inner_w / ($hi - $lo);
2024
2025	$w -= $page;
2026	$page &= ~1;
2027	glTranslate $page * 0.5, 0, 0;
2028	$page ||= 2;
2029
2030	my $knob_a = $inner_pad_px + ($value - $page * 0.5);
2031	my $knob_b = $inner_pad_px + ($value + $page * 0.5);
2032
2033	glEnable GL_BLEND;
2034	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
2035	glEnable GL_TEXTURE_2D;	2317	glEnable GL_TEXTURE_2D;
2036	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2318	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2037		2319
2038	# draw background	2320	# draw background
2039	$tex[1]->draw_quad (0, 0, $w, $h);	2321	$tex[1]->draw_quad_alpha (0, 0, 1, 1);
2040		2322
2041	# draw handle	2323	# draw handle
2042	$tex[0]->draw_quad ($knob_a, 0, $knob_b - $knob_a, $h);	2324	$tex[0]->draw_quad_alpha ($self->{knob_x}, 0, $self->{knob_w}, 1);
2043		2325
2044	glDisable GL_BLEND;
2045	glDisable GL_TEXTURE_2D;	2326	glDisable GL_TEXTURE_2D;
2046	}	2327	}
		2328
		2329	#############################################################################
		2330
		2331	package CFClient::UI::ValSlider;
		2332
		2333	our @ISA = CFClient::UI::HBox::;
		2334
		2335	sub new {
		2336	my ($class, %arg) = @_;
		2337
		2338	my $range = delete $arg{range};
		2339
		2340	my $self = $class->SUPER::new (
		2341	slider => (new CFClient::UI::Slider expand => 1, range => $range),
		2342	entry => (new CFClient::UI::Label text => "", template => delete $arg{template}),
		2343	to_value => sub { shift },
		2344	from_value => sub { shift },
		2345	%arg,
		2346	);
		2347
		2348	$self->{slider}->connect (changed => sub {
		2349	my ($self, $value) = @_;
		2350	$self->{parent}{entry}->set_text ($self->{parent}{to_value}->($value));
		2351	$self->{parent}->emit (changed => $value);
		2352	});
		2353
		2354	# $self->{entry}->connect (changed => sub {
		2355	# my ($self, $value) = @_;
		2356	# $self->{parent}{slider}->set_value ($self->{parent}{from_value}->($value));
		2357	# $self->{parent}->emit (changed => $value);
		2358	# });
		2359
		2360	$self->add ($self->{slider}, $self->{entry});
		2361
		2362	$self->{slider}->emit (changed => $self->{slider}{range}[0]);
		2363
		2364	$self
		2365	}
		2366
		2367	sub set_range { shift->{slider}->set_range (@_) }
		2368	sub set_value { shift->{slider}->set_value (@_) }
2047		2369
2048	#############################################################################	2370	#############################################################################
2049		2371
2050	package CFClient::UI::TextView;	2372	package CFClient::UI::TextView;
2051		2373
…		…
2060	fontsize => 1,	2382	fontsize => 1,
2061	can_events => 0,	2383	can_events => 0,
2062	#font => default_font	2384	#font => default_font
2063	@_,	2385	@_,
2064		2386
2065	layout => (new CFClient::Layout),	2387	layout => (new CFClient::Layout 1),
2066	par => [],	2388	par => [],
2067	height => 0,	2389	height => 0,
2068	children => [	2390	children => [
2069	(new CFClient::UI::Empty expand => 1),	2391	(new CFClient::UI::Empty expand => 1),
2070	(new CFClient::UI::Slider vertical => 1),	2392	(new CFClient::UI::Slider vertical => 1),
2071	],	2393	],
2072	);	2394	);
2073		2395
2074	$self->{children}[1]->connect (changed => sub {	2396	$self->{children}[1]->connect (changed => sub { $self->update });
2075	$self->update;
2076	});
2077		2397
2078	$self	2398	$self
2079	}	2399	}
2080		2400
2081	sub set_fontsize {	2401	sub set_fontsize {
2082	my ($self, $fontsize) = @_;	2402	my ($self, $fontsize) = @_;
2083		2403
2084	$self->{fontsize} = $fontsize;	2404	$self->{fontsize} = $fontsize;
2085	$self->reflow;	2405	$self->reflow;
2086	}
2087
2088	sub text_height {
2089	my ($self, $text) = @_;
2090
2091	my $layout = $self->{layout};
2092
2093	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
2094	$layout->set_width ($self->{w});
2095	$layout->set_text ($text);
2096
2097	($layout->size)[1]
2098	}
2099
2100	sub reflow {
2101	my ($self) = @_;
2102
2103	$self->{need_reflow}++;
2104	$self->update;
2105	}	2406	}
2106		2407
2107	sub size_allocate {	2408	sub size_allocate {
2108	my ($self, $w, $h) = @_;	2409	my ($self, $w, $h) = @_;
2109		2410
…		…
2114	$self->{layout}->set_width ($self->{children}[0]{w});	2415	$self->{layout}->set_width ($self->{children}[0]{w});
2115		2416
2116	$self->reflow;	2417	$self->reflow;
2117	}	2418	}
2118		2419
		2420	sub text_size {
		2421	my ($self, $text, $indent) = @_;
		2422
		2423	my $layout = $self->{layout};
		2424
		2425	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2426	$layout->set_width ($self->{children}[0]{w} - $indent);
		2427	$layout->set_markup ($text);
		2428
		2429	$layout->size
		2430	}
		2431
		2432	sub reflow {
		2433	my ($self) = @_;
		2434
		2435	$self->{need_reflow}++;
		2436	$self->update;
		2437	}
		2438
		2439	sub set_offset {
		2440	my ($self, $offset) = @_;
		2441
		2442	# todo: base offset on lines or so, not on pixels
		2443	$self->{children}[1]->set_value ($offset);
		2444	}
		2445
		2446	sub clear {
		2447	my ($self) = @_;
		2448
		2449	$self->{par} = [];
		2450	$self->{height} = 0;
		2451	$self->{children}[1]->set_range ([0, 0, 0, 1, 1]);
		2452	}
		2453
2119	sub add_paragraph {	2454	sub add_paragraph {
2120	my ($self, $color, $text) = @_;	2455	my ($self, $color, $text, $indent) = @_;
2121		2456
2122	#TODO: intelligently "reformat" paragraph	2457	for my $line (split /\n/, $text) {
2123		2458	my ($w, $h) = $self->text_size ($line);
2124	my $height = $self->text_height ($text);
2125
2126	$self->{height} += $height;	2459	$self->{height} += $h;
		2460	push @{$self->{par}}, [$w + $indent, $h, $color, $indent, $line];
		2461	}
2127		2462
2128	push @{$self->{par}}, [$height, $color, $text];
2129
2130	$self->{children}[1]{range} = [$self->{height} - $self->{h}, 0, $self->{height}, $self->{h}];	2463	$self->{children}[1]->set_range ([$self->{height}, 0, $self->{height}, $self->{h}, 1]);
2131	$self->{children}[1]->update;
2132	}	2464	}
2133		2465
2134	sub update {	2466	sub update {
2135	my ($self) = @_;	2467	my ($self) = @_;
2136		2468
…		…
2138		2470
2139	return unless $self->{h} > 0;	2471	return unless $self->{h} > 0;
2140		2472
2141	delete $self->{texture};	2473	delete $self->{texture};
2142		2474
2143	$ROOT->on_refresh ($self, sub {	2475	$ROOT->on_post_alloc ($self, sub {
		2476	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};
		2477
2144	if (delete $self->{need_reflow}) {	2478	if (delete $self->{need_reflow}) {
2145	my $height = 0;	2479	my $height = 0;
2146		2480
2147	$height += $_->[0] = $self->text_height ($_->[2])	2481	my $layout = $self->{layout};
		2482
		2483	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2484
2148	for @{$self->{par}};	2485	for (@{$self->{par}}) {
		2486	if (1 || $_->[0] >= $W) { # TODO: works,but needs reconfigure etc. support
		2487	$layout->set_width ($W - $_->[3]);
		2488	$layout->set_markup ($_->[4]);
		2489	my ($w, $h) = $layout->size;
		2490	$_->[0] = $w + $_->[3];
		2491	$_->[1] = $h;
		2492	}
		2493
		2494	$height += $_->[1];
		2495	}
2149		2496
2150	$self->{height} = $height;	2497	$self->{height} = $height;
2151		2498
2152	$self->{children}[1]{range} = [$height - $self->{h}, 0, $height, $self->{h}];	2499	$self->{children}[1]->set_range ([$height, 0, $height, $H, 1]);
2153		2500
2154	delete $self->{texture};	2501	delete $self->{texture};
2155	}	2502	}
2156		2503
2157	$self->{texture} ||= new_from_opengl CFClient::Texture $self->{w}, $self->{h}, sub {	2504	$self->{texture} ||= new_from_opengl CFClient::Texture $W, $H, sub {
2158	glClearColor 0, 0, 0, 1;	2505	glClearColor 0.5, 0.5, 0.5, 0;
2159	glClear GL_COLOR_BUFFER_BIT;	2506	glClear GL_COLOR_BUFFER_BIT;
2160		2507
		2508	my $top = int $self->{children}[1]{range}[0];
		2509
		2510	my $y0 = $top;
		2511	my $y1 = $top + $H;
		2512
		2513	my $y = 0;
		2514
		2515	my $layout = $self->{layout};
		2516
		2517	$layout->set_font ($self->{font}) if $self->{font};
		2518
2161	glEnable GL_BLEND;	2519	glEnable GL_BLEND;
		2520	#TODO# not correct in windows where rgba is forced off
2162	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	2521	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
2163	glEnable GL_TEXTURE_2D;
2164	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2165
2166	my $top = int $self->{children}[1]{range}[0];
2167
2168	my $y0 = $top;
2169	my $y1 = $top + $self->{h};
2170
2171	my $y = 0;
2172
2173	my $layout = $self->{layout};
2174
2175	$layout->set_font ($self->{font}) if $self->{font};
2176		2522
2177	for my $par (@{$self->{par}}) {	2523	for my $par (@{$self->{par}}) {
2178	my $h = $par->[0];	2524	my $h = $par->[1];
2179		2525
2180	if ($y0 < $y + $h && $y < $y1) {	2526	if ($y0 < $y + $h && $y < $y1) {
		2527	$layout->set_foreground (@{ $par->[2] });
		2528	$layout->set_width ($W - $par->[3]);
2181	$layout->set_text ($par->[2]);	2529	$layout->set_markup ($par->[4]);
2182		2530
2183	glColor @{ $par->[1] };	2531	my ($w, $h, $data, $format, $internalformat) = $layout->render;
2184	my ($W, $H) = $layout->size;	2532
2185	CFClient::Texture->new_from_layout ($layout)->draw_quad (0, $y - $y0);	2533	glRasterPos $par->[3], $y - $y0;
		2534	glDrawPixels $w, $h, $format, GL_UNSIGNED_BYTE, $data;
2186	}	2535	}
2187		2536
2188	$y += $h;	2537	$y += $h;
2189	}	2538	}
2190		2539
2191	glDisable GL_TEXTURE_2D;
2192	glDisable GL_BLEND;	2540	glDisable GL_BLEND;
2193	};	2541	};
2194	});	2542	});
2195	}	2543	}
2196		2544
2197	sub _draw {	2545	sub _draw {
2198	my ($self) = @_;	2546	my ($self) = @_;
2199		2547
2200	if ($self->{texture}) {
2201	glEnable GL_TEXTURE_2D;	2548	glEnable GL_TEXTURE_2D;
2202	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2549	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2203	glColor 1, 1, 1, 1;	2550	glColor 1, 1, 1, 1;
2204	$self->{texture}->draw_quad (0, 0, $self->{w}, $self->{h});	2551	$self->{texture}->draw_quad_alpha (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});
2205	glDisable GL_TEXTURE_2D;	2552	glDisable GL_TEXTURE_2D;
2206	}
2207		2553
2208	$self->{children}[1]->draw;	2554	$self->{children}[1]->draw;
2209		2555
2210	}	2556	}
2211		2557
…		…
2259		2605
2260	sub new {	2606	sub new {
2261	my $class = shift;	2607	my $class = shift;
2262		2608
2263	my $self = $class->SUPER::new (	2609	my $self = $class->SUPER::new (
2264	state => 0,	2610	state => 0,
2265	connect_activate => \&toggle_flopper,	2611	on_activate => \&toggle_flopper,
2266	@_	2612	@_
2267	);	2613	);
2268		2614
2269	if ($self->{state}) {
2270	$self->{state} = 0;
2271	$self->toggle_flopper;
2272	}
2273
2274	$self	2615	$self
2275	}	2616	}
2276		2617
2277	sub toggle_flopper {	2618	sub toggle_flopper {
2278	my ($self) = @_;	2619	my ($self) = @_;
2279		2620
2280	# TODO: use animation	2621	$self->{other}->toggle_visibility;
2281	if ($self->{state} = !$self->{state}) {
2282	$CFClient::UI::ROOT->add ($self->{other});
2283	$self->{other}->move ($self->coord2global (0, $self->{h}));
2284	$self->emit ("open");
2285	} else {
2286	$CFClient::UI::ROOT->remove ($self->{other});
2287	$self->emit ("close");
2288	}
2289
2290	$self->emit (changed => $self->{state});
2291	}	2622	}
2292		2623
2293	#############################################################################	2624	#############################################################################
2294		2625
2295	package CFClient::UI::Tooltip;	2626	package CFClient::UI::Tooltip;
…		…
2305	@_,	2636	@_,
2306	can_events => 0,	2637	can_events => 0,
2307	)	2638	)
2308	}	2639	}
2309		2640
2310	sub set_markup {	2641	sub set_tooltip_from {
2311	my ($self, $text) = @_;	2642	my ($self, $widget) = @_;
2312		2643
2313	$self->{label} ||= new CFClient::UI::Label fontsize => 0.8, fg => [0, 0, 0];	2644	my $tooltip = $widget->{tooltip};
2314	$self->{label}->set_markup ($text);	2645
2315	$self->add ($self->{label});	2646	if ($ENV{CFPLUS_DEBUG} & 2) {
		2647	$tooltip .= "\n\n" . (ref $widget) . "\n"
		2648	. "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n"
		2649	. "req $widget->{req_w} $widget->{req_h}\n"
		2650	. "visible $widget->{visible}";
		2651	}
		2652
		2653	$self->add (new CFClient::UI::Label
		2654	markup => $tooltip,
		2655	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
		2656	fontsize => 0.8,
		2657	fg => [0, 0, 0, 1],
		2658	ellipsise => 0,
		2659	font => ($widget->{tooltip_font} || $::FONT_PROP),
		2660	);
2316	}	2661	}
2317		2662
2318	sub size_request {	2663	sub size_request {
2319	my ($self) = @_;	2664	my ($self) = @_;
2320
2321	$self->child->set_max_size ($::WIDTH * 0.3);
2322		2665
2323	my ($w, $h) = @{$self->child}{qw(req_w req_h)};	2666	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
2324		2667
2325	($w + 4, $h + 4)	2668	($w + 4, $h + 4)
2326	}	2669	}
…		…
2329	my ($self, $w, $h) = @_;	2672	my ($self, $w, $h) = @_;
2330		2673
2331	$self->SUPER::size_allocate ($w - 4, $h - 4);	2674	$self->SUPER::size_allocate ($w - 4, $h - 4);
2332	}	2675	}
2333		2676
		2677	sub visibility_change {
		2678	my ($self, $visible) = @_;
		2679
		2680	return unless $visible;
		2681
		2682	$self->{root}->on_post_alloc ("move_$self" => sub {
		2683	my $widget = $self->{owner}
		2684	or return;
		2685
		2686	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
		2687
		2688	($x, $y) = $widget->coord2global (-$self->{w}, 0)
		2689	if $x + $self->{w} > $::WIDTH;
		2690
		2691	$self->move_abs ($x, $y);
		2692	});
		2693	}
		2694
2334	sub _draw {	2695	sub _draw {
2335	my ($self) = @_;	2696	my ($self) = @_;
2336		2697
2337	glPushMatrix;
2338	glTranslate 0.375, 0.375;	2698	glTranslate 0.375, 0.375;
2339		2699
2340	my ($w, $h) = @$self{qw(w h)};	2700	my ($w, $h) = @$self{qw(w h)};
2341		2701
2342	glColor 1, 0.8, 0.4;	2702	glColor 1, 0.8, 0.4;
…		…
2353	glVertex 0 , $h;	2713	glVertex 0 , $h;
2354	glVertex $w, $h;	2714	glVertex $w, $h;
2355	glVertex $w, 0;	2715	glVertex $w, 0;
2356	glEnd;	2716	glEnd;
2357		2717
2358	glPopMatrix;	2718	glTranslate 2 - 0.375, 2 - 0.375;
2359		2719
2360	glTranslate 2, 2;
2361	$self->SUPER::_draw;	2720	$self->SUPER::_draw;
2362	}	2721	}
2363		2722
2364	#############################################################################	2723	#############################################################################
2365		2724
…		…
2370	use CFClient::OpenGL;	2729	use CFClient::OpenGL;
2371		2730
2372	sub new {	2731	sub new {
2373	my $class = shift;	2732	my $class = shift;
2374		2733
2375	$class->SUPER::new (	2734	my $self = $class->SUPER::new (
2376	aspect => 1,	2735	aspect => 1,
		2736	can_events => 0,
2377	@_,	2737	@_,
2378	)	2738	);
		2739
		2740	if ($self->{anim} && $self->{animspeed}) {
		2741	Scalar::Util::weaken (my $widget = $self);
		2742
		2743	$self->{timer} = Event->timer (
		2744	at => $self->{animspeed} * int $::NOW / $self->{animspeed},
		2745	hard => 1,
		2746	interval => $self->{animspeed},
		2747	cb => sub {
		2748	++$widget->{frame};
		2749	$widget->update;
		2750	},
		2751	);
		2752	}
		2753
		2754	$self
2379	}	2755	}
2380		2756
2381	sub size_request {	2757	sub size_request {
2382	(32, 8)	2758	(32, 8)
2383	}	2759	}
2384		2760
		2761	sub update {
		2762	my ($self) = @_;
		2763
		2764	return unless $self->{visible};
		2765
		2766	$self->SUPER::update;
		2767	}
		2768
2385	sub draw {	2769	sub _draw {
2386	my ($self) = @_;	2770	my ($self) = @_;
2387		2771
		2772	return unless $::CONN;
		2773
		2774	my $face;
		2775
		2776	if ($self->{frame}) {
		2777	my $anim = $::CONN->{anim}[$self->{anim}];
		2778
		2779	$face = $anim->[ $self->{frame} % @$anim ]
		2780	if $anim && @$anim;
		2781	}
		2782
2388	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$self->{face}]];	2783	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];
2389		2784
2390	if ($tex) {	2785	if ($tex) {
2391	glEnable GL_BLEND;
2392	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
2393	glEnable GL_TEXTURE_2D;	2786	glEnable GL_TEXTURE_2D;
2394	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2787	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2395	glColor 1, 1, 1, 1;	2788	glColor 1, 1, 1, 1;
2396	$tex->draw_quad (0, 0, $self->{w}, $self->{h});	2789	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
2397	glDisable GL_TEXTURE_2D;	2790	glDisable GL_TEXTURE_2D;
2398	glDisable GL_BLEND;
2399	}	2791	}
		2792	}
		2793
		2794	sub DESTROY {
		2795	my ($self) = @_;
		2796
		2797	$self->{timer}->cancel
		2798	if $self->{timer};
		2799
		2800	$self->SUPER::DESTROY;
2400	}	2801	}
2401		2802
2402	#############################################################################	2803	#############################################################################
2403		2804
		2805	package CFClient::UI::Menu;
		2806
		2807	our @ISA = CFClient::UI::FancyFrame::;
		2808
		2809	use CFClient::OpenGL;
		2810
		2811	sub new {
		2812	my $class = shift;
		2813
		2814	my $self = $class->SUPER::new (
		2815	items => [],
		2816	z => 100,
		2817	@_,
		2818	);
		2819
		2820	$self->add ($self->{vbox} = new CFClient::UI::VBox);
		2821
		2822	for my $item (@{ $self->{items} }) {
		2823	my ($widget, $cb) = @$item;
		2824
		2825	# handle various types of items, only text for now
		2826	if (!ref $widget) {
		2827	$widget = new CFClient::UI::Label
		2828	can_hover => 1,
		2829	can_events => 1,
		2830	text => $widget;
		2831	}
		2832
		2833	$self->{item}{$widget} = $item;
		2834
		2835	$self->{vbox}->add ($widget);
		2836	}
		2837
		2838	$self
		2839	}
		2840
		2841	# popup given the event (must be a mouse button down event currently)
		2842	sub popup {
		2843	my ($self, $ev) = @_;
		2844
		2845	$self->_emit ("popdown");
		2846
		2847	# maybe save $GRAB? must be careful about events...
		2848	$GRAB = $self;
		2849	$self->{button} = $ev->{button};
		2850
		2851	$self->show;
		2852	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);
		2853	}
		2854
		2855	sub mouse_motion {
		2856	my ($self, $ev, $x, $y) = @_;
		2857
		2858	# TODO: should use vbox->find_widget or so
		2859	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});
		2860	$self->{hover} = $self->{item}{$HOVER};
		2861	}
		2862
		2863	sub button_up {
		2864	my ($self, $ev, $x, $y) = @_;
		2865
		2866	if ($ev->{button} == $self->{button}) {
		2867	undef $GRAB;
		2868	$self->hide;
		2869
		2870	$self->_emit ("popdown");
		2871	$self->{hover}[1]->() if $self->{hover};
		2872	}
		2873	}
		2874
		2875	#############################################################################
		2876
		2877	package CFClient::UI::Statusbox;
		2878
		2879	our @ISA = CFClient::UI::VBox::;
		2880
		2881	sub new {
		2882	my $class = shift;
		2883
		2884	$class->SUPER::new (
		2885	fontsize => 0.8,
		2886	@_,
		2887	)
		2888	}
		2889
		2890	sub reorder {
		2891	my ($self) = @_;
		2892	my $NOW = time;
		2893
		2894	while (my ($k, $v) = each %{ $self->{item} }) {
		2895	delete $self->{item}{$k} if $v->{timeout} < $NOW;
		2896	}
		2897
		2898	my @widgets;
		2899
		2900	my @items = sort {
		2901	$a->{pri} <=> $b->{pri}
		2902	or $b->{id} <=> $a->{id}
		2903	} values %{ $self->{item} };
		2904
		2905	my $count = 10 + 1;
		2906	for my $item (@items) {
		2907	last unless --$count;
		2908
		2909	push @widgets, $item->{label} ||= do {
		2910	# TODO: doesn't handle markup well (read as: at all)
		2911	my $short = $item->{count} > 1
		2912	? "<b>$item->{count} ×</b> $item->{text}"
		2913	: $item->{text};
		2914
		2915	for ($short) {
		2916	s/^\s+//;
		2917	s/\s+/ /g;
		2918	}
		2919
		2920	new CFClient::UI::Label
		2921	markup => $short,
		2922	tooltip => $item->{tooltip},
		2923	tooltip_font => $::FONT_PROP,
		2924	tooltip_width => 0.67,
		2925	fontsize => $item->{fontsize} || $self->{fontsize},
		2926	max_w => $::WIDTH * 0.44,
		2927	fg => $item->{fg},
		2928	can_events => 1,
		2929	can_hover => 1
		2930	};
		2931	}
		2932
		2933	$self->clear;
		2934	$self->SUPER::add (reverse @widgets);
		2935	}
		2936
		2937	sub add {
		2938	my ($self, $text, %arg) = @_;
		2939
		2940	$text =~ s/^\s+//;
		2941	$text =~ s/\s+$//;
		2942
		2943	return unless $text;
		2944
		2945	my $timeout = time + ((delete $arg{timeout}) || 60);
		2946
		2947	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};
		2948
		2949	if (my $item = $self->{item}{$group}) {
		2950	if ($item->{text} eq $text) {
		2951	$item->{count}++;
		2952	} else {
		2953	$item->{count} = 1;
		2954	$item->{text} = $item->{tooltip} = $text;
		2955	}
		2956	$item->{id} = ++$self->{id};
		2957	$item->{timeout} = $timeout;
		2958	delete $item->{label};
		2959	} else {
		2960	$self->{item}{$group} = {
		2961	id => ++$self->{id},
		2962	text => $text,
		2963	timeout => $timeout,
		2964	tooltip => $text,
		2965	fg => [0.8, 0.8, 0.8, 0.8],
		2966	pri => 0,
		2967	count => 1,
		2968	%arg,
		2969	};
		2970	}
		2971
		2972	$self->reorder;
		2973	}
		2974
		2975	sub reconfigure {
		2976	my ($self) = @_;
		2977
		2978	delete $_->{label}
		2979	for values %{ $self->{item} || {} };
		2980
		2981	$self->reorder;
		2982	$self->SUPER::reconfigure;
		2983	}
		2984
		2985	#############################################################################
		2986
		2987	package CFClient::UI::Inventory;
		2988
		2989	our @ISA = CFClient::UI::ScrolledWindow::;
		2990
		2991	sub new {
		2992	my $class = shift;
		2993
		2994	my $self = $class->SUPER::new (
		2995	scrolled => (new CFClient::UI::Table col_expand => [0, 1, 0]),
		2996	@_,
		2997	);
		2998
		2999	$self
		3000	}
		3001
		3002	sub set_items {
		3003	my ($self, $items) = @_;
		3004
		3005	$self->{scrolled}->clear;
		3006	return unless $items;
		3007
		3008	my @items = sort {
		3009	($a->{type} <=> $b->{type})
		3010	or ($a->{name} cmp $b->{name})
		3011	} @$items;
		3012
		3013	$self->{real_items} = \@items;
		3014
		3015	my $row = 0;
		3016	for my $item (@items) {
		3017	CFClient::Item::update_widgets $item;
		3018
		3019	$self->{scrolled}->add (0, $row, $item->{face_widget});
		3020	$self->{scrolled}->add (1, $row, $item->{desc_widget});
		3021	$self->{scrolled}->add (2, $row, $item->{weight_widget});
		3022
		3023	$row++;
		3024	}
		3025	}
		3026
		3027	#############################################################################
		3028
		3029	package CFClient::UI::BindEditor;
		3030
		3031	our @ISA = CFClient::UI::FancyFrame::;
		3032
		3033	sub new {
		3034	my $class = shift;
		3035
		3036	my $self = $class->SUPER::new (binding => [], commands => [], @_);
		3037
		3038	$self->add (my $vb = new CFClient::UI::VBox);
		3039
		3040
		3041	$vb->add ($self->{rec_btn} = new CFClient::UI::Button
		3042	text => "start recording",
		3043	tooltip => "Start/Stops recording of actions."
		3044	."All subsequent actions after the recording started will be captured."
		3045	."The actions are displayed after the record was stopped."
		3046	."To bind the action you have to click on the 'Bind' button",
		3047	on_activate => sub {
		3048	unless ($self->{recording}) {
		3049	$self->start;
		3050	} else {
		3051	$self->stop;
		3052	}
		3053	});
		3054
		3055	$vb->add (new CFClient::UI::Label text => "Actions:");
		3056	$vb->add ($self->{cmdbox} = new CFClient::UI::VBox);
		3057
		3058	$vb->add (new CFClient::UI::Label text => "Bound to: ");
		3059	$vb->add (my $hb = new CFClient::UI::HBox);
		3060	$hb->add ($self->{keylbl} = new CFClient::UI::Label expand => 1);
		3061	$hb->add (new CFClient::UI::Button
		3062	text => "bind",
		3063	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
		3064	on_activate => sub {
		3065	$self->ask_for_bind;
		3066	});
		3067
		3068	$vb->add (my $hb = new CFClient::UI::HBox);
		3069	$hb->add (new CFClient::UI::Button
		3070	text => "ok",
		3071	expand => 1,
		3072	tooltip => "This closes the binding editor and saves the binding",
		3073	on_activate => sub {
		3074	$self->hide;
		3075	$self->commit;
		3076	});
		3077
		3078	$hb->add (new CFClient::UI::Button
		3079	text => "cancel",
		3080	expand => 1,
		3081	tooltip => "This closes the binding editor without saving",
		3082	on_activate => sub {
		3083	$self->hide;
		3084	$self->{binding_cancel}->()
		3085	if $self->{binding_cancel};
		3086	});
		3087
		3088	$self->update_binding_widgets;
		3089
		3090	$self
		3091	}
		3092
		3093	sub commit {
		3094	my ($self) = @_;
		3095	my ($mod, $sym, $cmds) = $self->get_binding;
		3096	if ($sym != 0 && @$cmds > 0) {
		3097	$::STATUSBOX->add ("Bound actions to '".CFClient::Binder::keycombo_to_name ($mod, $sym)
		3098	."'. Don't forget 'Save Config'!");
		3099	$self->{binding_change}->($mod, $sym, $cmds)
		3100	if $self->{binding_change};
		3101	} else {
		3102	$::STATUSBOX->add ("No action bound, no key or action specified!");
		3103	$self->{binding_cancel}->()
		3104	if $self->{binding_cancel};
		3105	}
		3106	}
		3107
		3108	sub start {
		3109	my ($self) = @_;
		3110
		3111	$self->{rec_btn}->set_text ("stop recording");
		3112	$self->{recording} = 1;
		3113	$self->clear_command_list;
		3114	$::CONN->start_record if $::CONN;
		3115	}
		3116
		3117	sub stop {
		3118	my ($self) = @_;
		3119
		3120	$self->{rec_btn}->set_text ("start recording");
		3121	$self->{recording} = 0;
		3122
		3123	my $rec;
		3124	$rec = $::CONN->stop_record if $::CONN;
		3125	return unless ref $rec eq 'ARRAY';
		3126	$self->set_command_list ($rec);
		3127	}
		3128
		3129	# if $commit is true, the binding will be set after the user entered a key combo
		3130	sub ask_for_bind {
		3131	my ($self, $commit) = @_;
		3132
		3133	CFClient::Binder::open_binding_dialog (sub {
		3134	my ($mod, $sym) = @_;
		3135	$self->{binding} = [$mod, $sym]; # XXX: how to stop that memleak?
		3136	$self->update_binding_widgets;
		3137	$self->commit if $commit;
		3138	});
		3139	}
		3140
		3141	# $mod and $sym are the modifiers and key symbol
		3142	# $cmds is a array ref of strings (the commands)
		3143	# $cb is the callback that is executed on OK
		3144	# $ccb is the callback that is executed on CANCEL and
		3145	# when the binding was unsuccessful on OK
		3146	sub set_binding {
		3147	my ($self, $mod, $sym, $cmds, $cb, $ccb) = @_;
		3148
		3149	$self->clear_command_list;
		3150	$self->{recording} = 0;
		3151	$self->{rec_btn}->set_text ("start recording");
		3152
		3153	$self->{binding} = [$mod, $sym];
		3154	$self->{commands} = $cmds;
		3155
		3156	$self->{binding_change} = $cb;
		3157	$self->{binding_cancel} = $ccb;
		3158
		3159	$self->update_binding_widgets;
		3160	}
		3161
		3162	# this is a shortcut method that asks for a binding
		3163	# and then just binds it.
		3164	sub do_quick_binding {
		3165	my ($self, $cmds) = @_;
		3166	$self->set_binding (undef, undef, $cmds, sub {
		3167	$::CFG->{bindings}->{$_[0]}->{$_[1]} = $_[2];
		3168	});
		3169	$self->ask_for_bind (1);
		3170	}
		3171
		3172	sub update_binding_widgets {
		3173	my ($self) = @_;
		3174	my ($mod, $sym, $cmds) = $self->get_binding;
		3175	$self->{keylbl}->set_text (CFClient::Binder::keycombo_to_name ($mod, $sym));
		3176	$self->set_command_list ($cmds);
		3177	}
		3178
		3179	sub get_binding {
		3180	my ($self) = @_;
		3181	return (
		3182	$self->{binding}->[0],
		3183	$self->{binding}->[1],
		3184	[ grep { defined $_ } @{$self->{commands}} ]
		3185	);
		3186	}
		3187
		3188	sub clear_command_list {
		3189	my ($self) = @_;
		3190	$self->{cmdbox}->clear ();
		3191	}
		3192
		3193	sub set_command_list {
		3194	my ($self, $cmds) = @_;
		3195
		3196	$self->{cmdbox}->clear ();
		3197	$self->{commands} = $cmds;
		3198
		3199	my $idx = 0;
		3200
		3201	for (@$cmds) {
		3202	$self->{cmdbox}->add (my $hb = new CFClient::UI::HBox);
		3203
		3204	my $i = $idx;
		3205	$hb->add (new CFClient::UI::Label text => $_);
		3206	$hb->add (new CFClient::UI::Button
		3207	text => "delete",
		3208	tooltip => "Deletes the action from the record",
		3209	on_activate => sub {
		3210	$self->{cmdbox}->remove ($hb);
		3211	$cmds->[$i] = undef;
		3212	});
		3213
		3214
		3215	$idx++
		3216	}
		3217	}
		3218
		3219	#############################################################################
		3220
		3221	package CFClient::UI::SpellList;
		3222
		3223	our @ISA = CFClient::UI::FancyFrame::;
		3224
		3225	sub new {
		3226	my $class = shift;
		3227
		3228	my $self = $class->SUPER::new (binding => [], commands => [], @_);
		3229
		3230	$self->add (new CFClient::UI::ScrolledWindow
		3231	scrolled => $self->{spellbox} = new CFClient::UI::Table);
		3232
		3233	$self;
		3234	}
		3235
		3236	# XXX: Do sorting? Argl...
		3237	sub add_spell {
		3238	my ($self, $spell) = @_;
		3239	$self->{spells}->{$spell->{name}} = $spell;
		3240
		3241	$self->{spellbox}->add (0, $self->{tbl_idx}, new CFClient::UI::Face
		3242	face => $spell->{face},
		3243	can_hover => 1,
		3244	can_events => 1,
		3245	tooltip => $spell->{message});
		3246
		3247	$self->{spellbox}->add (1, $self->{tbl_idx}, new CFClient::UI::Label
		3248	text => $spell->{name},
		3249	can_hover => 1,
		3250	can_events => 1,
		3251	tooltip => $spell->{message},
		3252	expand => 1);
		3253
		3254	$self->{spellbox}->add (2, $self->{tbl_idx}, new CFClient::UI::Label
		3255	text => (sprintf "lvl: %2d sp: %2d dmg: %2d",
		3256	$spell->{level}, ($spell->{mana} || $spell->{grace}), $spell->{damage}),
		3257	expand => 1);
		3258
		3259	$self->{spellbox}->add (3, $self->{tbl_idx}++, new CFClient::UI::Button
		3260	text => "bind to key",
		3261	on_activate => sub { $::BIND_EDITOR->do_quick_binding (["cast $spell->{name}"]) });
		3262	}
		3263
		3264	sub rebuild_spell_list {
		3265	my ($self) = @_;
		3266	$self->{tbl_idx} = 0;
		3267	$self->add_spell ($_) for values %{$self->{spells}};
		3268	}
		3269
		3270	sub remove_spell {
		3271	my ($self, $spell) = @_;
		3272	delete $self->{spells}->{$spell->{name}};
		3273	$self->rebuild_spell_list;
		3274	}
		3275
		3276	#############################################################################
		3277
2404	package CFClient::UI::Root;	3278	package CFClient::UI::Root;
2405		3279
2406	our @ISA = CFClient::UI::Container::;	3280	our @ISA = CFClient::UI::Container::;
2407		3281
2408	use CFClient::OpenGL;	3282	use CFClient::OpenGL;
2409		3283
2410	sub check_size {	3284	sub new {
2411	my ($self) = @_;	3285	my $class = shift;
2412		3286
2413	$self->configure (0, 0, $::WIDTH, $::HEIGHT);	3287	my $self = $class->SUPER::new (
		3288	visible => 1,
		3289	@_,
		3290	);
		3291
		3292	Scalar::Util::weaken ($self->{root} = $self);
		3293
		3294	$self
2414	}	3295	}
2415		3296
2416	sub size_request {	3297	sub size_request {
2417	($::WIDTH, $::HEIGHT)	3298	my ($self) = @_;
2418	}
2419		3299
2420	sub configure {	3300	($self->{w}, $self->{h})
		3301	}
		3302
		3303	sub _to_pixel {
		3304	my ($coord, $size, $max) = @_;
		3305
		3306	$coord =
		3307	$coord eq "center" ? ($max - $size) * 0.5
		3308	: $coord eq "max" ? $max
		3309	: $coord;
		3310
		3311	$coord = 0 if $coord < 0;
		3312	$coord = $max - $size if $coord > $max - $size;
		3313
		3314	int $coord + 0.5
		3315	}
		3316
		3317	sub size_allocate {
2421	my ($self, $x, $y, $w, $h) = @_;	3318	my ($self, $w, $h) = @_;
2422		3319
2423	$self->SUPER::configure ($x, $y, $w, $h);
2424
2425	for my $child (@{$self->{children}}) {	3320	for my $child ($self->children) {
2426	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};	3321	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};
2427		3322
2428	$X = List::Util::max 0, List::Util::min $w - $W, $X;	3323	$X = $child->{force_x} if exists $child->{force_x};
2429	$Y = List::Util::max 0, List::Util::min $h - $H, $Y;	3324	$Y = $child->{force_y} if exists $child->{force_y};
		3325
		3326	$X = _to_pixel $X, $W, $self->{w};
		3327	$Y = _to_pixel $Y, $H, $self->{h};
		3328
2430	$child->configure ($X, $Y, $W,$H);	3329	$child->configure ($X, $Y, $W, $H);
2431	}	3330	}
2432	}	3331	}
2433		3332
2434	sub _topleft {	3333	sub coord2local {
2435	my ($self, $x, $y) = @_;	3334	my ($self, $x, $y) = @_;
2436		3335
2437	($x, $y)	3336	($x, $y)
2438	}	3337	}
2439		3338
		3339	sub coord2global {
		3340	my ($self, $x, $y) = @_;
		3341
		3342	($x, $y)
		3343	}
		3344
2440	sub update {	3345	sub update {
2441	my ($self) = @_;	3346	my ($self) = @_;
2442		3347
2443	$self->check_size;	3348	$::WANT_REFRESH++;
2444	::refresh ();
2445	}	3349	}
2446		3350
2447	sub add {	3351	sub add {
2448	my ($self, $child) = @_;	3352	my ($self, @children) = @_;
2449		3353
2450	# integerize window positions	3354	$_->{is_toplevel} = 1
2451	$child->{x} = int $child->{x};	3355	for @children;
2452	$child->{y} = int $child->{y};
2453		3356
2454	$self->SUPER::add ($child);	3357	$self->SUPER::add (@children);
		3358	}
		3359
		3360	sub remove {
		3361	my ($self, @children) = @_;
		3362
		3363	$self->SUPER::remove (@children);
		3364
		3365	delete $self->{is_toplevel}
		3366	for @children;
		3367
		3368	while (@children) {
		3369	my $w = pop @children;
		3370	push @children, $w->children;
		3371	$w->set_invisible;
		3372	}
2455	}	3373	}
2456		3374
2457	sub on_refresh {	3375	sub on_refresh {
2458	my ($self, $id, $cb) = @_;	3376	my ($self, $id, $cb) = @_;
2459		3377
2460	$self->{refresh_hook}{$id} = $cb;	3378	$self->{refresh_hook}{$id} = $cb;
2461	}	3379	}
2462		3380
		3381	sub on_post_alloc {
		3382	my ($self, $id, $cb) = @_;
		3383
		3384	$self->{post_alloc_hook}{$id} = $cb;
		3385	}
		3386
2463	sub draw {	3387	sub draw {
2464	my ($self) = @_;	3388	my ($self) = @_;
2465		3389
2466	while (my $rcb = delete $self->{refresh_hook}) {	3390	while ($self->{refresh_hook}) {
2467	$_->() for values %$rcb;	3391	$_->()
		3392	for values %{delete $self->{refresh_hook}};
2468	}	3393	}
		3394
		3395	if ($self->{realloc}) {
		3396	my %queue;
		3397	my @queue;
		3398	my $widget;
		3399
		3400	outer:
		3401	while () {
		3402	if (my $realloc = delete $self->{realloc}) {
		3403	for $widget (values %$realloc) {
		3404	$widget->{visible} or next; # do not resize invisible widgets
		3405
		3406	$queue{$widget+0}++ and next; # duplicates are common
		3407
		3408	push @{ $queue[$widget->{visible}] }, $widget;
		3409	}
		3410	}
		3411
		3412	while () {
		3413	@queue or last outer;
		3414
		3415	$widget = pop @{ $queue[-1] || [] }
		3416	and last;
		3417
		3418	pop @queue;
		3419	}
		3420
		3421	delete $queue{$widget+0};
		3422
		3423	my ($w, $h) = $widget->size_request;
		3424
		3425	$w = List::Util::max $widget->{min_w}, $w + $widget->{padding_x} * 2;
		3426	$h = List::Util::max $widget->{min_h}, $h + $widget->{padding_y} * 2;
		3427
		3428	$w = $widget->{force_w} if exists $widget->{force_w};
		3429	$h = $widget->{force_h} if exists $widget->{force_h};
		3430
		3431	if ($widget->{req_w} != $w || $widget->{req_h} != $h
		3432	|| delete $widget->{force_realloc}) {
		3433	$widget->{req_w} = $w;
		3434	$widget->{req_h} = $h;
		3435
		3436	$self->{size_alloc}{$widget+0} = $widget;
		3437
		3438	if (my $parent = $widget->{parent}) {
		3439	$self->{realloc}{$parent+0} = $parent
		3440	unless $queue{$parent+0};
		3441
		3442	$parent->{force_size_alloc} = 1;
		3443	$self->{size_alloc}{$parent+0} = $parent;
		3444	}
		3445	}
		3446
		3447	delete $self->{realloc}{$widget+0};
		3448	}
		3449	}
		3450
		3451	while (my $size_alloc = delete $self->{size_alloc}) {
		3452	my @queue = sort { $b->{visible} <=> $a->{visible} }
		3453	values %$size_alloc;
		3454
		3455	while () {
		3456	my $widget = pop @queue || last;
		3457
		3458	my ($w, $h) = @$widget{qw(alloc_w alloc_h)};
		3459
		3460	$w = 0 if $w < 0;
		3461	$h = 0 if $h < 0;
		3462
		3463	$w = int $w + 0.5;
		3464	$h = int $h + 0.5;
		3465
		3466	if ($widget->{w} != $w || $widget->{h} != $h || delete $widget->{force_size_alloc}) {
		3467	$widget->{old_w} = $widget->{w};
		3468	$widget->{old_h} = $widget->{h};
		3469
		3470	$widget->{w} = $w;
		3471	$widget->{h} = $h;
		3472
		3473	$widget->emit (size_allocate => $w, $h);
		3474	}
		3475	}
		3476	}
		3477
		3478	while ($self->{post_alloc_hook}) {
		3479	$_->()
		3480	for values %{delete $self->{post_alloc_hook}};
		3481	}
		3482
2469		3483
2470	glViewport 0, 0, $::WIDTH, $::HEIGHT;	3484	glViewport 0, 0, $::WIDTH, $::HEIGHT;
2471	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	3485	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
2472	glClear GL_COLOR_BUFFER_BIT;	3486	glClear GL_COLOR_BUFFER_BIT;
2473		3487
2474	glMatrixMode GL_PROJECTION;	3488	glMatrixMode GL_PROJECTION;
2475	glLoadIdentity;	3489	glLoadIdentity;
2476	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000 , 10000;	3490	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;
2477	glMatrixMode GL_MODELVIEW;	3491	glMatrixMode GL_MODELVIEW;
2478	glLoadIdentity;	3492	glLoadIdentity;
2479		3493
		3494	{
		3495	package CFClient::UI::Base;
		3496
		3497	($draw_x, $draw_y, $draw_w, $draw_h) =
		3498	(0, 0, $self->{w}, $self->{h});
		3499	}
		3500
2480	$self->_draw;	3501	$self->_draw;
2481	}	3502	}
2482		3503
2483	#############################################################################	3504	#############################################################################
2484		3505
2485	package CFClient::UI;	3506	package CFClient::UI;
2486		3507
2487	$ROOT = new CFClient::UI::Root;	3508	$ROOT = new CFClient::UI::Root;
2488	$TOOLTIP = new CFClient::UI::Tooltip;	3509	$TOOLTIP = new CFClient::UI::Tooltip z => 900;
2489		3510
2490	1	3511	1
2491		3512

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines