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.202 by root, Sun May 14 20:51:19 2006 UTC vs.
Revision 1.278 by root, Sun Jun 4 23:05:06 2006 UTC

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

Diff Legend

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