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.231 by root, Thu May 25 00:26:19 2006 UTC vs.
Revision 1.265 by root, Thu Jun 1 02:59:46 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
		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	}
18		43
19	sub check_tooltip {	44	sub check_tooltip {
20	if (!$GRAB) {	45	if (!$GRAB) {
21	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {	46	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {
22	if (length $widget->{tooltip}) {	47	if (length $widget->{tooltip}) {
23		48
24	if ($TOOLTIP->{owner} != $widget) {	49	if ($TOOLTIP->{owner} != $widget) {
		50	$TOOLTIP->hide;
		51
25	$TOOLTIP->{owner} = $widget;	52	$TOOLTIP->{owner} = $widget;
26		53
27	my $tip = $widget->{tooltip};	54	my $tip = $widget->{tooltip};
28		55
29	$tip = $tip->($widget) if CODE:: eq ref $tip;	56	$tip = $tip->($widget) if CODE:: eq ref $tip;
30		57
31	$TOOLTIP->set_tooltip_from ($widget);	58	$TOOLTIP->set_tooltip_from ($widget);
32	$TOOLTIP->show;	59	$TOOLTIP->show;
33
34	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
35
36	($x, $y) = $widget->coord2global (-$TOOLTIP->{w}, 0)
37	if $x + $TOOLTIP->{w} > $::WIDTH;
38
39	$TOOLTIP->move ($x, $y);
40	$TOOLTIP->check_size;
41	$TOOLTIP->update;
42	}	60	}
43		61
44	return;	62	return;
45	}	63	}
46	}	64	}
…		…
152	sub rescale_widgets {	170	sub rescale_widgets {
153	my ($sx, $sy) = @_;	171	my ($sx, $sy) = @_;
154		172
155	for my $widget (values %WIDGET) {	173	for my $widget (values %WIDGET) {
156	if ($widget->{is_toplevel}) {	174	if ($widget->{is_toplevel}) {
		175	$widget->{x} += $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
		176	$widget->{y} += $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
		177
157	$widget->{x} = int 0.5 + $widget->{x} * $sx if exists $widget->{x};	178	$widget->{x} = int 0.5 + $widget->{x} * $sx if $widget->{x} =~ /^[0-9.]+$/;
158	$widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w};	179	$widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w};
159	$widget->{req_w} = int 0.5 + $widget->{req_w} * $sx if exists $widget->{req_w};	180	$widget->{force_w} = int 0.5 + $widget->{force_w} * $sx if exists $widget->{force_w};
160	$widget->{user_w} = int 0.5 + $widget->{user_w} * $sx if exists $widget->{user_w};
161	$widget->{y} = int 0.5 + $widget->{y} * $sy if exists $widget->{y};	181	$widget->{y} = int 0.5 + $widget->{y} * $sy if $widget->{y} =~ /^[0-9.]+$/;
162	$widget->{h} = int 0.5 + $widget->{h} * $sy if exists $widget->{h};	182	$widget->{h} = int 0.5 + $widget->{h} * $sy if exists $widget->{h};
163	$widget->{req_h} = int 0.5 + $widget->{req_h} * $sy if exists $widget->{req_h};	183	$widget->{force_h} = int 0.5 + $widget->{force_h} * $sy if exists $widget->{force_h};
164	$widget->{user_h} = int 0.5 + $widget->{user_h} * $sy if exists $widget->{user_h};	184
		185	$widget->{x} -= $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/;
		186	$widget->{y} -= $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/;
		187
165	}	188	}
166	}	189	}
167		190
168	reconfigure_widgets;	191	reconfigure_widgets;
169	}	192	}
…		…
178		201
179	sub new {	202	sub new {
180	my $class = shift;	203	my $class = shift;
181		204
182	my $self = bless {	205	my $self = bless {
183	x => 0,	206	x => "center",
184	y => 0,	207	y => "center",
185	z => 0,	208	z => 0,
		209	w => undef,
		210	h => undef,
186	can_events => 1,	211	can_events => 1,
187	@_	212	@_
188	}, $class;	213	}, $class;
189		214
		215	Scalar::Util::weaken ($CFClient::UI::WIDGET{$self+0} = $self);
		216
190	for (keys %$self) {	217	for (keys %$self) {
191	if (/^connect_(.*)$/) {	218	if (/^on_(.*)$/) {
192	$self->connect ($1 => delete $self->{$_});	219	$self->connect ($1 => delete $self->{$_});
193	}	220	}
194	}	221	}
195		222
196	Scalar::Util::weaken ($CFClient::UI::WIDGET{$self+0} = $self);	223	if (my $layout = $CFClient::UI::LAYOUT->{$self->{name}}) {
		224	$self->{x} = $layout->{x} * $CFClient::UI::ROOT->{alloc_w} if exists $layout->{x};
		225	$self->{y} = $layout->{y} * $CFClient::UI::ROOT->{alloc_h} if exists $layout->{y};
		226	$self->{force_w} = $layout->{w} * $CFClient::UI::ROOT->{alloc_w} if exists $layout->{w};
		227	$self->{force_h} = $layout->{h} * $CFClient::UI::ROOT->{alloc_h} if exists $layout->{h};
		228
		229	$self->{x} -= $self->{force_w} * 0.5 if exists $layout->{x};
		230	$self->{y} -= $self->{force_h} * 0.5 if exists $layout->{y};
		231
		232	$self->show if $layout->{show};
		233	}
197		234
198	$self	235	$self
199	}	236	}
200		237
201	sub destroy {	238	sub destroy {
…		…
205	%$self = ();	242	%$self = ();
206	}	243	}
207		244
208	sub show {	245	sub show {
209	my ($self) = @_;	246	my ($self) = @_;
		247
210	return if $self->{parent};	248	return if $self->{parent};
211		249
212	$CFClient::UI::ROOT->add ($self);	250	$CFClient::UI::ROOT->add ($self);
213	}	251	}
214		252
215	sub show_centered {	253	sub set_visible {
216	my ($self) = @_;	254	my ($self) = @_;
		255
217	return if $self->{parent};	256	return if $self->{visible};
218		257
219	$self->show;	258	$self->{root} = $self->{parent}{root};
		259	$self->{visible} = $self->{parent}{visible} + 1;
220		260
221	$CFClient::UI::ROOT->on_post_alloc (	261	$self->emit (visibility_change => 1);
222	"centered $self" => sub {	262
223	$self->move (($::WIDTH - $self->{w}) * 0.5, ($::HEIGHT - $self->{h}) * 0.5);	263	$self->realloc if !exists $self->{req_w};
224	},	264
225	);	265	$_->set_visible for $self->children;
226	}	266	}
227		267
228	sub set_invisible {	268	sub set_invisible {
229	my ($self) = @_;	269	my ($self) = @_;
230		270
231	# broken show/hide model	271	return unless $self->{visible};
232		272
		273	$_->set_invisible for $self->children;
		274
		275	delete $self->{root};
233	delete $self->{visible};	276	delete $self->{visible};
234		277
235	undef $GRAB if $GRAB == $self;	278	undef $GRAB if $GRAB == $self;
236	undef $HOVER if $HOVER == $self;	279	undef $HOVER if $HOVER == $self;
237		280
		281	CFClient::UI::check_tooltip
		282	if $TOOLTIP->{owner} == $self;
		283
238	$self->focus_out;	284	$self->focus_out;
		285
		286	$self->emit (visibility_change => 0);
		287	}
		288
		289	sub set_visibility {
		290	my ($self, $visible) = @_;
		291
		292	return if $self->{visible} == $visible;
		293
		294	$visible ? $self->hide
		295	: $self->show;
		296	}
		297
		298	sub toggle_visibility {
		299	my ($self) = @_;
		300
		301	$self->{visible}
		302	? $self->hide
		303	: $self->show;
239	}	304	}
240		305
241	sub hide {	306	sub hide {
242	my ($self) = @_;	307	my ($self) = @_;
243		308
…		…
245		310
246	$self->{parent}->remove ($self)	311	$self->{parent}->remove ($self)
247	if $self->{parent};	312	if $self->{parent};
248	}	313	}
249		314
250	sub move {	315	sub move_abs {
251	my ($self, $x, $y, $z) = @_;	316	my ($self, $x, $y, $z) = @_;
252		317
253	$self->{x} = int $x;	318	$self->{x} = List::Util::max 0, int $x;
254	$self->{y} = int $y;	319	$self->{y} = List::Util::max 0, int $y;
255	$self->{z} = $z if defined $z;	320	$self->{z} = $z if defined $z;
256		321
257	$self->update;	322	$self->update;
258	}	323	}
259		324
260	sub set_size {	325	sub set_size {
261	my ($self, $w, $h) = @_;	326	my ($self, $w, $h) = @_;
262		327
263	$self->{user_w} = $w;	328	$self->{force_w} = $w;
264	$self->{user_h} = $h;	329	$self->{force_h} = $h;
265		330
266	$self->check_size;	331	$self->realloc;
267	}	332	}
268		333
269	sub size_request {	334	sub size_request {
270	require Carp;	335	require Carp;
271	Carp::confess "size_request is abstract";	336	Carp::confess "size_request is abstract";
…		…
273		338
274	sub configure {	339	sub configure {
275	my ($self, $x, $y, $w, $h) = @_;	340	my ($self, $x, $y, $w, $h) = @_;
276		341
277	if ($self->{aspect}) {	342	if ($self->{aspect}) {
		343	my ($ow, $oh) = ($w, $h);
		344
278	my $w2 = List::Util::min $w, int $h * $self->{aspect};	345	$w = List::Util::min $w, int $h * $self->{aspect};
279	my $h2 = List::Util::min $h, int $w / $self->{aspect};	346	$h = List::Util::min $h, int $w / $self->{aspect};
280		347
281	# use alignment to adjust x, y	348	# use alignment to adjust x, y
282		349
283	$x += int +($w - $w2) * 0.5;	350	$x += int 0.5 * ($ow - $w);
284	$y += int +($h - $h2) * 0.5;	351	$y += int 0.5 * ($oh - $h);
285
286	($w, $h) = ($w2, $h2);
287	}	352	}
288		353
289	if ($self->{x} != $x || $self->{y} != $y) {	354	if ($self->{x} ne $x || $self->{y} ne $y) {
290	$self->{x} = $x;	355	$self->{x} = $x;
291	$self->{y} = $y;	356	$self->{y} = $y;
292	$self->update;	357	$self->update;
293	}	358	}
294		359
295	if ($self->{w} != $w || $self->{h} != $h) {	360	if ($self->{alloc_w} != $w || $self->{alloc_h} != $h) {
296	$CFClient::UI::ROOT->{size_alloc}{$self} = [$self, $w, $h];	361	return unless $self->{visible};
		362
		363	$self->{alloc_w} = $w;
		364	$self->{alloc_h} = $h;
		365
		366	$self->{root}{size_alloc}{$self+0} = $self;
297	}	367	}
298	}	368	}
299		369
300	sub size_allocate {	370	sub size_allocate {
301	# nothing to be done	371	# nothing to be done
302	}	372	}
303		373
304	sub reconfigure {
305	my ($self) = @_;
306
307	$self->check_size (1);
308	$self->update;
309	}
310
311	sub children {	374	sub children {
312	}	375	}
313		376
314	sub set_max_size {	377	sub set_max_size {
315	my ($self, $w, $h) = @_;	378	my ($self, $w, $h) = @_;
…		…
318	delete $self->{max_h}; $self->{max_h} = $h if $h;	381	delete $self->{max_h}; $self->{max_h} = $h if $h;
319	}	382	}
320		383
321	sub set_tooltip {	384	sub set_tooltip {
322	my ($self, $tooltip) = @_;	385	my ($self, $tooltip) = @_;
		386
		387	$tooltip =~ s/^\s+//;
		388	$tooltip =~ s/\s+$//;
		389
		390	return if $self->{tooltip} eq $tooltip;
323		391
324	$self->{tooltip} = $tooltip;	392	$self->{tooltip} = $tooltip;
325		393
326	if ($CFClient::UI::TOOLTIP->{owner} == $self) {	394	if ($CFClient::UI::TOOLTIP->{owner} == $self) {
327	delete $CFClient::UI::TOOLTIP->{owner};	395	delete $CFClient::UI::TOOLTIP->{owner};
…		…
386	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }	454	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }
387	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }	455	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }
388	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }	456	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }
389	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }	457	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }
390	sub z { $_[0]{z} = $_[1] if @_ > 1; $_[0]{z} }	458	sub z { $_[0]{z} = $_[1] if @_ > 1; $_[0]{z} }
		459
		460	sub find_widget {
		461	my ($self, $x, $y) = @_;
		462
		463	return () unless $self->{can_events};
		464
		465	return $self
		466	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
		467	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
		468
		469	()
		470	}
		471
		472	sub set_parent {
		473	my ($self, $parent) = @_;
		474
		475	Scalar::Util::weaken ($self->{parent} = $parent);
		476	$self->set_visible if $parent->{visible};
		477	}
		478
		479	sub connect {
		480	my ($self, $signal, $cb) = @_;
		481
		482	push @{ $self->{signal_cb}{$signal} }, $cb;
		483	}
		484
		485	sub _emit {
		486	my ($self, $signal, @args) = @_;
		487
		488	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
		489	}
		490
		491	sub emit {
		492	my ($self, $signal, @args) = @_;
		493
		494	$self->_emit ($signal, @args)
		495	|| $self->$signal (@args);
		496	}
		497
		498	sub visibility_change {
		499	#my ($self, $visible) = @_;
		500	}
		501
		502	sub realloc {
		503	my ($self) = @_;
		504
		505	if ($self->{visible}) {
		506	return if $self->{root}{realloc}{$self+0};
		507
		508	$self->{root}{realloc}{$self+0} = $self;
		509	$self->{root}->update;
		510	} else {
		511	delete $self->{req_w};
		512	delete $self->{req_h};
		513	}
		514	}
		515
		516	sub update {
		517	my ($self) = @_;
		518
		519	$self->{parent}->update
		520	if $self->{parent};
		521	}
		522
		523	sub reconfigure {
		524	my ($self) = @_;
		525
		526	$self->realloc;
		527	$self->update;
		528	}
391		529
392	sub draw {	530	sub draw {
393	my ($self) = @_;	531	my ($self) = @_;
394		532
395	return unless $self->{h} && $self->{w};	533	return unless $self->{h} && $self->{w};
…		…
412	glVertex $x , $y + $self->{h};	550	glVertex $x , $y + $self->{h};
413	glEnd;	551	glEnd;
414	glDisable GL_BLEND;	552	glDisable GL_BLEND;
415	}	553	}
416		554
417	if ($ENV{PCLIENT_DEBUG}) {	555	if ($ENV{CFPLUS_DEBUG} & 1) {
418	glPushMatrix;	556	glPushMatrix;
419	glColor 1, 1, 0, 1;	557	glColor 1, 1, 0, 1;
420	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;	558	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;
421	glBegin GL_LINE_LOOP;	559	glBegin GL_LINE_LOOP;
422	glVertex 0 , 0;	560	glVertex 0 , 0;
423	glVertex $self->{w}, 0;	561	glVertex $self->{w} - 1, 0;
424	glVertex $self->{w}, $self->{h};	562	glVertex $self->{w} - 1, $self->{h} - 1;
425	glVertex 0 , $self->{h};	563	glVertex 0 , $self->{h} - 1;
426	glEnd;	564	glEnd;
427	glPopMatrix;	565	glPopMatrix;
428	#CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;	566	#CFClient::UI::Label->new (w => $self->{w}, h => $self->{h}, text => $self, fontsize => 0)->_draw;
429	}	567	}
430	}	568	}
431		569
432	sub _draw {	570	sub _draw {
433	my ($self) = @_;	571	my ($self) = @_;
434		572
435	warn "no draw defined for $self\n";	573	warn "no draw defined for $self\n";
436	}
437
438	sub find_widget {
439	my ($self, $x, $y) = @_;
440
441	return () unless $self->{can_events};
442
443	return $self
444	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
445	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
446
447	()
448	}
449
450	sub set_parent {
451	my ($self, $parent) = @_;
452
453	Scalar::Util::weaken ($self->{parent} = $parent);
454
455	# TODO: req_w _does_change after ->reconfigure
456	$self->check_size
457	unless exists $self->{req_w};
458
459	$self->show;
460	}
461
462	sub check_size {
463	my ($self, $forced) = @_;
464
465	$self->{force_alloc} = 1 if $forced;
466	$CFClient::UI::ROOT->{check_size}{$self} = $self;
467	}
468
469	sub update {
470	my ($self) = @_;
471
472	$self->{parent}->update
473	if $self->{parent};
474	}
475
476	sub connect {
477	my ($self, $signal, $cb) = @_;
478
479	push @{ $self->{signal_cb}{$signal} }, $cb;
480	}
481
482	sub _emit {
483	my ($self, $signal, @args) = @_;
484
485	List::Util::sum map $_->($self, @args), @{$self->{signal_cb}{$signal} || []}
486	}
487
488	sub emit {
489	my ($self, $signal, @args) = @_;
490
491	$self->_emit ($signal, @args)
492	|| $self->$signal (@args);
493	}	574	}
494		575
495	sub DESTROY {	576	sub DESTROY {
496	my ($self) = @_;	577	my ($self) = @_;
497		578
…		…
555	my ($class, %arg) = @_;	636	my ($class, %arg) = @_;
556	$class->SUPER::new (can_events => 0, %arg);	637	$class->SUPER::new (can_events => 0, %arg);
557	}	638	}
558		639
559	sub size_request {	640	sub size_request {
560	(0, 0)	641	my ($self) = @_;
		642
		643	($self->{w} + 0, $self->{h} + 0)
561	}	644	}
562		645
563	sub draw { }	646	sub draw { }
564		647
565	#############################################################################	648	#############################################################################
…		…
594	$self->{children} = [	677	$self->{children} = [
595	sort { $a->{z} <=> $b->{z} }	678	sort { $a->{z} <=> $b->{z} }
596	@{$self->{children}}, @widgets	679	@{$self->{children}}, @widgets
597	];	680	];
598		681
599	$self->check_size (1);	682	$self->realloc;
600	$self->update;
601	}	683	}
602		684
603	sub children {	685	sub children {
604	@{ $_[0]{children} }	686	@{ $_[0]{children} }
605	}	687	}
…		…
610	delete $child->{parent};	692	delete $child->{parent};
611	$child->hide;	693	$child->hide;
612		694
613	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];	695	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];
614		696
615	$self->check_size;	697	$self->realloc;
616	$self->update;
617	}	698	}
618		699
619	sub clear {	700	sub clear {
620	my ($self) = @_;	701	my ($self) = @_;
621		702
…		…
625	for (@$children) {	706	for (@$children) {
626	delete $_->{parent};	707	delete $_->{parent};
627	$_->hide;	708	$_->hide;
628	}	709	}
629		710
630	$self->check_size;	711	$self->realloc;
631	$self->update;
632	}	712	}
633		713
634	sub find_widget {	714	sub find_widget {
635	my ($self, $x, $y) = @_;	715	my ($self, $x, $y) = @_;
636		716
…		…
760		840
761	package CFClient::UI::ViewPort;	841	package CFClient::UI::ViewPort;
762		842
763	our @ISA = CFClient::UI::Window::;	843	our @ISA = CFClient::UI::Window::;
764		844
		845	sub new {
		846	my $class = shift;
		847
		848	$class->SUPER::new (
		849	scroll_x => 0,
		850	scroll_y => 1,
		851	@_,
		852	)
		853	}
		854
765	sub size_request {	855	sub size_request {
766	my ($self) = @_;	856	my ($self) = @_;
767		857
768	@$self{qw(child_w child_h)} = @{$self->child}{qw(req_w req_h)};	858	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
769		859
770	@$self{qw(child_w child_h)}	860	$w = 10 if $self->{scroll_x};
		861	$h = 10 if $self->{scroll_y};
		862
		863	($w, $h)
771	}	864	}
772		865
773	sub size_allocate {	866	sub size_allocate {
774	my ($self, $w, $h) = @_;	867	my ($self, $w, $h) = @_;
775		868
776	my ($cw, $ch) = @$self{qw(child_w child_h)};	869	my $child = $self->child;
777	# $w = $self->{w};	870
		871	$w = $child->{req_w} if $self->{scroll_x} && $child->{req_w};
		872	$h = $child->{req_h} if $self->{scroll_y} && $child->{req_h};
		873
778	$self->child->configure (0, 0, $cw, $ch);	874	$self->child->configure (0, 0, $w, $h);
779	$self->update;	875	$self->update;
780	}	876	}
781		877
782	sub set_offset {	878	sub set_offset {
783	my ($self, $x, $y) = @_;	879	my ($self, $x, $y) = @_;
…		…
834	my $class = shift;	930	my $class = shift;
835		931
836	my $self;	932	my $self;
837		933
838	my $slider = new CFClient::UI::Slider	934	my $slider = new CFClient::UI::Slider
839	vertical => 1,	935	vertical => 1,
840	range => [0, 0, 1, 0.01], # HACK fix	936	range => [0, 0, 1, 0.01], # HACK fix
841	connect_changed => sub {	937	on_changed => sub {
842	$self->{vp}->set_offset (0, $_[1]);	938	$self->{vp}->set_offset (0, $_[1]);
843	},	939	},
844	;	940	;
845		941
846	$self = $class->SUPER::new (	942	$self = $class->SUPER::new (
…		…
852	$self->{vp}->add ($self->{scrolled});	948	$self->{vp}->add ($self->{scrolled});
853	$self->add ($self->{vp});	949	$self->add ($self->{vp});
854	$self->add ($self->{slider});	950	$self->add ($self->{slider});
855		951
856	$self	952	$self
		953	}
		954
		955	sub update {
		956	my ($self) = @_;
		957
		958	$self->SUPER::update;
		959
		960	# todo: overwrite size_allocate of child
		961	my $child = $self->{vp}->child;
		962	$self->{slider}->set_range ([$self->{slider}{range}[0], 0, $child->{h}, $self->{vp}{h}, 1]);
857	}	963	}
858		964
859	sub size_allocate {	965	sub size_allocate {
860	my ($self, $w, $h) = @_;	966	my ($self, $w, $h) = @_;
861		967
…		…
914		1020
915	our @ISA = CFClient::UI::Bin::;	1021	our @ISA = CFClient::UI::Bin::;
916		1022
917	use CFClient::OpenGL;	1023	use CFClient::OpenGL;
918		1024
919	my @tex =	1025	my $bg =
		1026	new_from_file CFClient::Texture CFClient::find_rcfile "d1_bg.png",
		1027	mipmap => 1, wrap => 1;
		1028
		1029	my @border =
920	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }	1030	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
921	qw(d1_bg.png d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);	1031	qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png);
922		1032
923	sub new {	1033	sub new {
924	my $class = shift;	1034	my $class = shift;
925
926	# TODO: user_x, user_y, overwrite moveto?
927		1035
928	my $self = $class->SUPER::new (	1036	my $self = $class->SUPER::new (
929	bg => [1, 1, 1, 1],	1037	bg => [1, 1, 1, 1],
930	border_bg => [1, 1, 1, 1],	1038	border_bg => [1, 1, 1, 1],
931	border => 0.6,	1039	border => 0.6,
932	is_toplevel => 1,
933	can_events => 1,	1040	can_events => 1,
		1041	min_w => 16,
		1042	min_h => 16,
934	@_	1043	@_
935	);	1044	);
936		1045
937	$self->{title} &&= new CFClient::UI::Label	1046	$self->{title} &&= new CFClient::UI::Label
938	align => 0,	1047	align => 0,
…		…
991	my ($ev, $x, $y) = @_;	1100	my ($ev, $x, $y) = @_;
992		1101
993	my $dx = $ev->{x} - $ox;	1102	my $dx = $ev->{x} - $ox;
994	my $dy = $ev->{y} - $oy;	1103	my $dy = $ev->{y} - $oy;
995		1104
996	$self->{user_w} = $bw + $dx * ($mx ? -1 : 1);	1105	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);
997	$self->{user_h} = $bh + $dy * ($my ? -1 : 1);	1106	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);
		1107
		1108	$self->realloc;
998	$self->move ($wx + $dx * $mx, $wy + $dy * $my);	1109	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
999	$self->check_size;
1000	};	1110	};
1001		1111
1002	} elsif ($lr ^ $td) {	1112	} elsif ($lr ^ $td) {
1003	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1113	my ($ox, $oy) = ($ev->{x}, $ev->{y});
1004	my ($bx, $by) = ($self->{x}, $self->{y});	1114	my ($bx, $by) = ($self->{x}, $self->{y});
…		…
1006	$self->{motion} = sub {	1116	$self->{motion} = sub {
1007	my ($ev, $x, $y) = @_;	1117	my ($ev, $x, $y) = @_;
1008		1118
1009	($x, $y) = ($ev->{x}, $ev->{y});	1119	($x, $y) = ($ev->{x}, $ev->{y});
1010		1120
1011	$self->move ($bx + $x - $ox, $by + $y - $oy);	1121	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);
1012	$self->update;
1013	};	1122	};
1014	}	1123	}
1015	}	1124	}
1016		1125
1017	sub button_up {	1126	sub button_up {
…		…
1036	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;	1145	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
1037		1146
1038	my $border = $self->border;	1147	my $border = $self->border;
1039		1148
1040	glColor @{ $self->{border_bg} };	1149	glColor @{ $self->{border_bg} };
1041	$tex[1]->draw_quad_alpha (0, 0, $w, $border);	1150	$border[0]->draw_quad_alpha (0, 0, $w, $border);
1042	$tex[3]->draw_quad_alpha (0, $border, $border, $ch);	1151	$border[1]->draw_quad_alpha (0, $border, $border, $ch);
1043	$tex[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);	1152	$border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);
1044	$tex[4]->draw_quad_alpha (0, $h - $border, $w, $border);	1153	$border[3]->draw_quad_alpha (0, $h - $border, $w, $border);
1045		1154
1046	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {	1155	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {
1047	my $bg = $tex[0];	1156	glColor @{ $self->{bg} };
1048		1157
1049	# TODO: repeat texture not scale	1158	# TODO: repeat texture not scale
		1159	# solve this better(?)
1050	my $rep_x = $cw / $bg->{w};	1160	$bg->{s} = $cw / $bg->{w};
1051	my $rep_y = $ch / $bg->{h};	1161	$bg->{t} = $ch / $bg->{h};
1052
1053	glColor @{ $self->{bg} };
1054
1055	$bg->{s} = $rep_x;
1056	$bg->{t} = $rep_y;
1057	$bg->{wrap_mode} = 1;
1058	$bg->draw_quad_alpha ($border, $border, $cw, $ch);	1162	$bg->draw_quad_alpha ($border, $border, $cw, $ch);
1059	}	1163	}
1060		1164
1061	glDisable GL_TEXTURE_2D;	1165	glDisable GL_TEXTURE_2D;
1062		1166
…		…
1078	sub new {	1182	sub new {
1079	my $class = shift;	1183	my $class = shift;
1080		1184
1081	$class->SUPER::new (	1185	$class->SUPER::new (
1082	col_expand => [],	1186	col_expand => [],
1083	@_	1187	@_,
1084	)	1188	)
		1189	}
		1190
		1191	sub children {
		1192	grep $_, map @$_, grep $_, @{ $_[0]{children} }
1085	}	1193	}
1086		1194
1087	sub add {	1195	sub add {
1088	my ($self, $x, $y, $child) = @_;	1196	my ($self, $x, $y, $child) = @_;
1089		1197
1090	$child->set_parent ($self);	1198	$child->set_parent ($self);
1091	$self->{children}[$y][$x] = $child;	1199	$self->{children}[$y][$x] = $child;
1092		1200
1093	$child->check_size;	1201	$self->realloc;
1094	}	1202	}
1095		1203
1096	sub children {
1097	grep $_, map @$_, grep $_, @{ $_[0]{children} }
1098	}
1099
1100	# TODO: move to container class maybe? send childs a signal on removal?	1204	# TODO: move to container class maybe? send children a signal on removal?
1101	sub clear {	1205	sub clear {
1102	my ($self) = @_;	1206	my ($self) = @_;
1103		1207
1104	my @children = $self->children;	1208	my @children = $self->children;
1105	delete $self->{children};	1209	delete $self->{children};
…		…
1107	for (@children) {	1211	for (@children) {
1108	delete $_->{parent};	1212	delete $_->{parent};
1109	$_->hide;	1213	$_->hide;
1110	}	1214	}
1111		1215
1112	$self->update;	1216	$self->realloc;
1113	}	1217	}
1114		1218
1115	sub get_wh {	1219	sub get_wh {
1116	my ($self) = @_;	1220	my ($self) = @_;
1117		1221
…		…
1148	sub size_allocate {	1252	sub size_allocate {
1149	my ($self, $w, $h) = @_;	1253	my ($self, $w, $h) = @_;
1150		1254
1151	my ($ws, $hs) = $self->get_wh;	1255	my ($ws, $hs) = $self->get_wh;
1152		1256
1153	my $req_w = sum @$ws;	1257	my $req_w = (sum @$ws) || 1;
1154	my $req_h = sum @$hs;	1258	my $req_h = (sum @$hs) || 1;
1155		1259
1156	# TODO: nicer code && do row_expand	1260	# TODO: nicer code && do row_expand
1157	my @col_expand = @{$self->{col_expand}};	1261	my @col_expand = @{$self->{col_expand}};
1158	@col_expand = (1) x @$ws unless @col_expand;	1262	@col_expand = (1) x @$ws unless @col_expand;
1159	my $col_expand = (sum @col_expand) || 1;	1263	my $col_expand = (sum @col_expand) || 1;
…		…
1213	}	1317	}
1214	}	1318	}
1215		1319
1216	#############################################################################	1320	#############################################################################
1217		1321
1218	package CFClient::UI::HBox;	1322	package CFClient::UI::Box;
1219
1220	# TODO: wrap into common Box base class
1221		1323
1222	our @ISA = CFClient::UI::Container::;	1324	our @ISA = CFClient::UI::Container::;
1223		1325
1224	sub size_request {	1326	sub size_request {
1225	my ($self) = @_;	1327	my ($self) = @_;
1226		1328
1227	my @alloc = map [$_->size_request], @{$self->{children}};	1329	$self->{vertical}
1228		1330	? (
1229	(	1331	(List::Util::max map $_->{req_w}, @{$self->{children}}),
1230	(List::Util::sum map $_->[0], @alloc),	1332	(List::Util::sum map $_->{req_h}, @{$self->{children}}),
1231	(List::Util::max map $_->[1], @alloc),	1333	)
1232	)	1334	: (
		1335	(List::Util::sum map $_->{req_w}, @{$self->{children}}),
		1336	(List::Util::max map $_->{req_h}, @{$self->{children}}),
		1337	)
1233	}	1338	}
1234		1339
1235	sub size_allocate {	1340	sub size_allocate {
1236	my ($self, $w, $h) = @_;	1341	my ($self, $w, $h) = @_;
1237		1342
1238	($h, $w) = ($w, $h);	1343	my $space = $self->{vertical} ? $h : $w;
1239
1240	my $children = $self->{children};	1344	my $children = $self->{children};
1241		1345
1242	my @h = map $_->{req_w}, @$children;	1346	my @req;
1243		1347
1244	my $req_h = List::Util::sum @h;	1348	if ($self->{homogeneous}) {
1245		1349	@req = ($space / (@$children || 1)) x @$children;
1246	if ($req_h > $h) {
1247	# ah well, not enough space
1248	$_ *= $h / $req_h for @h;
1249	} else {	1350	} else {
		1351	@req = map $_->{$self->{vertical} ? "req_h" : "req_w"}, @$children;
		1352	my $req = List::Util::sum @req;
		1353
		1354	if ($req > $space) {
		1355	# ah well, not enough space
		1356	$_ *= $space / $req for @req;
		1357	} else {
1250	my $exp = List::Util::sum map $_->{expand}, @$children;	1358	my $expand = (List::Util::sum map $_->{expand}, @$children) || 1;
1251	$exp ||= 1;
1252		1359
		1360	$space = ($space - $req) / $expand; # remaining space to give away
		1361
		1362	$req[$_] += $space * $children->[$_]{expand}
1253	for (0 .. $#$children) {	1363	for 0 .. $#$children;
1254	my $child = $children->[$_];
1255
1256	my $alloc_h = $h[$_];
1257	$alloc_h += ($h - $req_h) * $child->{expand} / $exp;
1258	$h[$_] = $alloc_h;
1259	}	1364	}
1260	}	1365	}
1261		1366
1262	CFClient::UI::harmonize \@h;	1367	CFClient::UI::harmonize \@req;
1263		1368
1264	my $y = 0;	1369	my $pos = 0;
1265	for (0 .. $#$children) {	1370	for (0 .. $#$children) {
1266	my $child = $children->[$_];
1267	my $h = $h[$_];	1371	my $alloc = $req[$_];
1268	$child->configure ($y, 0, $h, $w);	1372	$children->[$_]->configure ($self->{vertical} ? (0, $pos, $w, $alloc) : ($pos, 0, $alloc, $h));
1269		1373
1270	$y += $h;	1374	$pos += $alloc;
1271	}	1375	}
1272		1376
1273	1	1377	1
1274	}	1378	}
1275		1379
1276	#############################################################################	1380	#############################################################################
1277		1381
		1382	package CFClient::UI::HBox;
		1383
		1384	our @ISA = CFClient::UI::Box::;
		1385
		1386	sub new {
		1387	my $class = shift;
		1388
		1389	$class->SUPER::new (
		1390	vertical => 0,
		1391	@_,
		1392	)
		1393	}
		1394
		1395	#############################################################################
		1396
1278	package CFClient::UI::VBox;	1397	package CFClient::UI::VBox;
1279		1398
1280	# TODO: wrap into common Box base class
1281
1282	our @ISA = CFClient::UI::Container::;	1399	our @ISA = CFClient::UI::Box::;
1283		1400
1284	sub size_request {	1401	sub new {
1285	my ($self) = @_;	1402	my $class = shift;
1286		1403
1287	my @alloc = map [$_->size_request], @{$self->{children}};	1404	$class->SUPER::new (
1288		1405	vertical => 1,
1289	(	1406	@_,
1290	(List::Util::max map $_->[0], @alloc),
1291	(List::Util::sum map $_->[1], @alloc),
1292	)	1407	)
1293	}
1294
1295	sub size_allocate {
1296	my ($self, $w, $h) = @_;
1297
1298	Carp::confess "negative size" if $w < 0 || $h < 0;#d#
1299
1300	my $children = $self->{children};
1301
1302	my @h = map $_->{req_h}, @$children;
1303
1304	my $req_h = List::Util::sum @h;
1305
1306	if ($req_h > $h) {
1307	# ah well, not enough space
1308	$_ *= $h / $req_h for @h;
1309	} else {
1310	my $exp = List::Util::sum map $_->{expand}, @$children;
1311	$exp ||= 1;
1312
1313	for (0 .. $#$children) {
1314	my $child = $children->[$_];
1315
1316	$h[$_] += ($h - $req_h) * $child->{expand} / $exp;
1317	}
1318	}
1319
1320	CFClient::UI::harmonize \@h;
1321
1322	my $y = 0;
1323	for (0 .. $#$children) {
1324	my $child = $children->[$_];
1325	my $h = $h[$_];
1326	$child->configure (0, $y, $w, $h);
1327
1328	$y += $h;
1329	}
1330
1331	1
1332	}	1408	}
1333		1409
1334	#############################################################################	1410	#############################################################################
1335		1411
1336	package CFClient::UI::Label;	1412	package CFClient::UI::Label;
…		…
1353	ellipsise => 3, # end	1429	ellipsise => 3, # end
1354	layout => (new CFClient::Layout),	1430	layout => (new CFClient::Layout),
1355	fontsize => 1,	1431	fontsize => 1,
1356	align => -1,	1432	align => -1,
1357	valign => -1,	1433	valign => -1,
1358	padding => 2,	1434	padding_x => 2,
		1435	padding_y => 2,
1359	can_events => 0,	1436	can_events => 0,
1360	%arg	1437	%arg
1361	);	1438	);
1362		1439
1363	if (exists $self->{template}) {	1440	if (exists $self->{template}) {
…		…
1399	$self->{text} = "T$text";	1476	$self->{text} = "T$text";
1400		1477
1401	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;	1478	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;
1402	$self->{layout}->set_text ($text);	1479	$self->{layout}->set_text ($text);
1403		1480
		1481	$self->realloc;
1404	$self->update;	1482	$self->update;
1405	$self->check_size;
1406	}	1483	}
1407		1484
1408	sub set_markup {	1485	sub set_markup {
1409	my ($self, $markup) = @_;	1486	my ($self, $markup) = @_;
1410		1487
…		…
1414	my $rgba = $markup =~ /span.*(?:foreground|background)/;	1491	my $rgba = $markup =~ /span.*(?:foreground|background)/;
1415		1492
1416	$self->{layout} = new CFClient::Layout $rgba if $self->{layout}->is_rgba != $rgba;	1493	$self->{layout} = new CFClient::Layout $rgba if $self->{layout}->is_rgba != $rgba;
1417	$self->{layout}->set_markup ($markup);	1494	$self->{layout}->set_markup ($markup);
1418		1495
		1496	$self->realloc;
1419	$self->update;	1497	$self->update;
1420	$self->check_size;
1421	}	1498	}
1422		1499
1423	sub size_request {	1500	sub size_request {
1424	my ($self) = @_;	1501	my ($self) = @_;
1425		1502
…		…
1439		1516
1440	$w = List::Util::max $w, $w2;	1517	$w = List::Util::max $w, $w2;
1441	$h = List::Util::max $h, $h2;	1518	$h = List::Util::max $h, $h2;
1442	}	1519	}
1443		1520
1444	(	1521	($w, $h)
1445	$w + $self->{padding} * 2,
1446	$h + $self->{padding} * 2,
1447	)
1448	}	1522	}
1449		1523
1450	sub size_allocate {	1524	sub size_allocate {
1451	my ($self, $w, $h) = @_;	1525	my ($self, $w, $h) = @_;
1452		1526
1453	delete $self->{texture};	1527	delete $self->{texture}
		1528	;#d#
1454	}	1529	}
1455		1530
1456	sub set_fontsize {	1531	sub set_fontsize {
1457	my ($self, $fontsize) = @_;	1532	my ($self, $fontsize) = @_;
1458		1533
1459	$self->{fontsize} = $fontsize;	1534	$self->{fontsize} = $fontsize;
1460	delete $self->{texture};	1535	delete $self->{texture};
1461		1536
1462	$self->update;	1537	$self->realloc;
1463	$self->check_size;
1464	}	1538	}
1465		1539
1466	sub _draw {	1540	sub _draw {
1467	my ($self) = @_;	1541	my ($self) = @_;
1468		1542
…		…
1476	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});	1550	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1477	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1551	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1478		1552
1479	my $tex = new_from_layout CFClient::Texture $self->{layout};	1553	my $tex = new_from_layout CFClient::Texture $self->{layout};
1480		1554
1481	$self->{ox} = int ($self->{align} < 0 ? $self->{padding}	1555	$self->{ox} = int ($self->{align} < 0 ? $self->{padding_x}
1482	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding}	1556	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding_x}
1483	: ($self->{w} - $tex->{w}) * 0.5);	1557	: ($self->{w} - $tex->{w}) * 0.5);
1484		1558
1485	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding}	1559	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding_y}
1486	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding}	1560	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding_y}
1487	: ($self->{h} - $tex->{h}) * 0.5);	1561	: ($self->{h} - $tex->{h}) * 0.5);
1488		1562
1489	$tex	1563	$tex
1490	};	1564	};
1491		1565
…		…
1548	sub set_text {	1622	sub set_text {
1549	my ($self, $text) = @_;	1623	my ($self, $text) = @_;
1550		1624
1551	$self->{cursor} = length $text;	1625	$self->{cursor} = length $text;
1552	$self->_set_text ($text);	1626	$self->_set_text ($text);
1553	$self->update;	1627
1554	$self->check_size;	1628	$self->realloc;
1555	}	1629	}
1556		1630
1557	sub get_text {	1631	sub get_text {
1558	$_[0]{text}	1632	$_[0]{text}
1559	}	1633	}
…		…
1562	my ($self) = @_;	1636	my ($self) = @_;
1563		1637
1564	my ($w, $h) = $self->SUPER::size_request;	1638	my ($w, $h) = $self->SUPER::size_request;
1565		1639
1566	($w + 1, $h) # add 1 for cursor	1640	($w + 1, $h) # add 1 for cursor
1567	}
1568
1569	sub size_allocate {
1570	my ($self, $w, $h) = @_;
1571
1572	$self->_set_text (delete $self->{text});#d# don't check for == inside _set_text
1573	}	1641	}
1574		1642
1575	sub key_down {	1643	sub key_down {
1576	my ($self, $ev) = @_;	1644	my ($self, $ev) = @_;
1577		1645
…		…
1598	} elsif ($uni) {	1666	} elsif ($uni) {
1599	substr $text, $self->{cursor}++, 0, chr $uni;	1667	substr $text, $self->{cursor}++, 0, chr $uni;
1600	}	1668	}
1601		1669
1602	$self->_set_text ($text);	1670	$self->_set_text ($text);
1603	$self->update;	1671
1604	$self->check_size;	1672	$self->realloc;
1605	}	1673	}
1606		1674
1607	sub focus_in {	1675	sub focus_in {
1608	my ($self) = @_;	1676	my ($self) = @_;
1609		1677
…		…
1736		1804
1737	sub new {	1805	sub new {
1738	my $class = shift;	1806	my $class = shift;
1739		1807
1740	$class->SUPER::new (	1808	$class->SUPER::new (
1741	padding => 4,	1809	padding_x => 4,
		1810	padding_y => 4,
1742	fg => [1, 1, 1],	1811	fg => [1, 1, 1],
1743	active_fg => [0, 0, 1],	1812	active_fg => [0, 0, 1],
1744	can_hover => 1,	1813	can_hover => 1,
1745	align => 0,	1814	align => 0,
1746	valign => 0,	1815	valign => 0,
…		…
1793		1862
1794	sub new {	1863	sub new {
1795	my $class = shift;	1864	my $class = shift;
1796		1865
1797	$class->SUPER::new (	1866	$class->SUPER::new (
1798	padding => 2,	1867	padding_x => 2,
		1868	padding_y => 2,
1799	fg => [1, 1, 1],	1869	fg => [1, 1, 1],
1800	active_fg => [1, 1, 0],	1870	active_fg => [1, 1, 0],
1801	bg => [0, 0, 0, 0.2],	1871	bg => [0, 0, 0, 0.2],
1802	active_bg => [1, 1, 1, 0.5],	1872	active_bg => [1, 1, 1, 0.5],
1803	state => 0,	1873	state => 0,
…		…
1807	}	1877	}
1808		1878
1809	sub size_request {	1879	sub size_request {
1810	my ($self) = @_;	1880	my ($self) = @_;
1811		1881
1812	($self->{padding} * 2 + 6) x 2	1882	(6) x 2
1813	}	1883	}
1814		1884
1815	sub button_down {	1885	sub button_down {
1816	my ($self, $ev, $x, $y) = @_;	1886	my ($self, $ev, $x, $y) = @_;
1817		1887
1818	if ($x >= $self->{padding} && $x < $self->{w} - $self->{padding}	1888	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1819	&& $y >= $self->{padding} && $y < $self->{h} - $self->{padding}) {	1889	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1820	$self->{state} = !$self->{state};	1890	$self->{state} = !$self->{state};
1821	$self->_emit (changed => $self->{state});	1891	$self->_emit (changed => $self->{state});
1822	}	1892	}
1823	}	1893	}
1824		1894
1825	sub _draw {	1895	sub _draw {
1826	my ($self) = @_;	1896	my ($self) = @_;
1827		1897
1828	$self->SUPER::_draw;	1898	$self->SUPER::_draw;
1829		1899
1830	glTranslate $self->{padding} + 0.375, $self->{padding} + 0.375, 0;	1900	glTranslate $self->{padding_x} + 0.375, $self->{padding_y} + 0.375, 0;
1831		1901
1832	my $s = (List::Util::min @$self{qw(w h)}) - $self->{padding} * 2;	1902	my ($w, $h) = @$self{qw(w h)};
		1903
		1904	my $s = List::Util::min $w - $self->{padding_x} * 2, $h - $self->{padding_y} * 2;
1833		1905
1834	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };	1906	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };
1835		1907
1836	my $tex = $self->{state} ? $tex[1] : $tex[0];	1908	my $tex = $self->{state} ? $tex[1] : $tex[0];
1837		1909
…		…
2102	fg => [1, 1, 1],	2174	fg => [1, 1, 1],
2103	active_fg => [0, 0, 0],	2175	active_fg => [0, 0, 0],
2104	bg => [0, 0, 0, 0.2],	2176	bg => [0, 0, 0, 0.2],
2105	active_bg => [1, 1, 1, 0.5],	2177	active_bg => [1, 1, 1, 0.5],
2106	range => [0, 0, 100, 10, 0],	2178	range => [0, 0, 100, 10, 0],
2107	req_w => $::WIDTH / 80,	2179	min_w => $::WIDTH / 80,
2108	req_h => $::WIDTH / 80,	2180	min_h => $::WIDTH / 80,
2109	vertical => 0,	2181	vertical => 0,
2110	can_hover => 1,	2182	can_hover => 1,
2111	inner_pad => 0.02,	2183	inner_pad => 0.02,
2112	@_	2184	@_
2113	);	2185	);
…		…
2116	$self->update;	2188	$self->update;
2117		2189
2118	$self	2190	$self
2119	}	2191	}
2120		2192
		2193	sub changed { }
		2194
2121	sub set_range {	2195	sub set_range {
2122	my ($self, $range) = @_;	2196	my ($self, $range) = @_;
2123		2197
2124	$self->{range} = $range;	2198	($range, $self->{range}) = ($self->{range}, $range);
2125		2199
2126	$self->update;	2200	$self->update
		2201	if "@$range" ne "@{$self->{range}}";
2127	}	2202	}
2128		2203
2129	sub set_value {	2204	sub set_value {
2130	my ($self, $value) = @_;	2205	my ($self, $value) = @_;
2131		2206
…		…
2150	}	2225	}
2151		2226
2152	sub size_request {	2227	sub size_request {
2153	my ($self) = @_;	2228	my ($self) = @_;
2154		2229
2155	my $w = $self->{req_w};	2230	($self->{req_w}, $self->{req_h})
2156	my $h = $self->{req_h};
2157
2158	$self->{vertical} ? ($h, $w) : ($w, $h)
2159	}	2231	}
2160		2232
2161	sub button_down {	2233	sub button_down {
2162	my ($self, $ev, $x, $y) = @_;	2234	my ($self, $ev, $x, $y) = @_;
2163		2235
…		…
2514		2586
2515	sub new {	2587	sub new {
2516	my $class = shift;	2588	my $class = shift;
2517		2589
2518	my $self = $class->SUPER::new (	2590	my $self = $class->SUPER::new (
2519	state => 0,	2591	state => 0,
2520	connect_activate => \&toggle_flopper,	2592	on_activate => \&toggle_flopper,
2521	@_	2593	@_
2522	);	2594	);
2523		2595
2524	if ($self->{state}) {
2525	$self->{state} = 0;
2526	$self->toggle_flopper;
2527	}
2528
2529	$self	2596	$self
2530	}	2597	}
2531		2598
2532	sub toggle_flopper {	2599	sub toggle_flopper {
2533	my ($self) = @_;	2600	my ($self) = @_;
2534		2601
2535	# TODO: use animation	2602	$self->{other}->toggle_visibility;
2536	if ($self->{state} = !$self->{state}) {
2537	$CFClient::UI::ROOT->add ($self->{other});
2538	$self->{other}->move ($self->coord2global (0, $self->{h}));
2539	$self->_emit ("open");
2540	} else {
2541	$CFClient::UI::ROOT->remove ($self->{other});
2542	$self->_emit ("close");
2543	}
2544
2545	$self->_emit (changed => $self->{state});
2546	}	2603	}
2547		2604
2548	#############################################################################	2605	#############################################################################
2549		2606
2550	package CFClient::UI::Tooltip;	2607	package CFClient::UI::Tooltip;
…		…
2563	}	2620	}
2564		2621
2565	sub set_tooltip_from {	2622	sub set_tooltip_from {
2566	my ($self, $widget) = @_;	2623	my ($self, $widget) = @_;
2567		2624
		2625	my $tooltip = $widget->{tooltip};
		2626
		2627	if ($ENV{CFPLUS_DEBUG} & 2) {
		2628	$tooltip .= "\n\n" . (ref $widget) . "\n"
		2629	. "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n"
		2630	. "req $widget->{req_w} $widget->{req_h}\n"
		2631	. "visible $widget->{visible}";
		2632	}
		2633
2568	$self->add (new CFClient::UI::Label	2634	$self->add (new CFClient::UI::Label
2569	markup => $widget->{tooltip},	2635	markup => $tooltip,
2570	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,	2636	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
2571	fontsize => 0.8,	2637	fontsize => 0.8,
2572	fg => [0, 0, 0, 1],	2638	fg => [0, 0, 0, 1],
2573	ellipsise => 0,	2639	ellipsise => 0,
2574	font => ($widget->{tooltip_font} || $::FONT_PROP),	2640	font => ($widget->{tooltip_font} || $::FONT_PROP),
…		…
2585		2651
2586	sub size_allocate {	2652	sub size_allocate {
2587	my ($self, $w, $h) = @_;	2653	my ($self, $w, $h) = @_;
2588		2654
2589	$self->SUPER::size_allocate ($w - 4, $h - 4);	2655	$self->SUPER::size_allocate ($w - 4, $h - 4);
		2656	}
		2657
		2658	sub visibility_change {
		2659	my ($self, $visible) = @_;
		2660
		2661	return unless $visible;
		2662
		2663	$self->{root}->on_post_alloc ("move_$self" => sub {
		2664	my $widget = $self->{owner}
		2665	or return;
		2666
		2667	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
		2668
		2669	($x, $y) = $widget->coord2global (-$self->{w}, 0)
		2670	if $x + $self->{w} > $::WIDTH;
		2671
		2672	$self->move_abs ($x, $y);
		2673	});
2590	}	2674	}
2591		2675
2592	sub _draw {	2676	sub _draw {
2593	my ($self) = @_;	2677	my ($self) = @_;
2594		2678
…		…
2611	glVertex $w, $h;	2695	glVertex $w, $h;
2612	glVertex $w, 0;	2696	glVertex $w, 0;
2613	glEnd;	2697	glEnd;
2614		2698
2615	glTranslate 2 - 0.375, 2 - 0.375;	2699	glTranslate 2 - 0.375, 2 - 0.375;
		2700
2616	$self->SUPER::_draw;	2701	$self->SUPER::_draw;
2617	}	2702	}
2618		2703
2619	#############################################################################	2704	#############################################################################
2620		2705
…		…
2626		2711
2627	sub new {	2712	sub new {
2628	my $class = shift;	2713	my $class = shift;
2629		2714
2630	my $self = $class->SUPER::new (	2715	my $self = $class->SUPER::new (
2631	aspect => 1,	2716	aspect => 1,
		2717	can_events => 0,
2632	@_,	2718	@_,
2633	);	2719	);
2634		2720
2635	if ($self->{anim} && $self->{animspeed}) {	2721	if ($self->{anim} && $self->{animspeed}) {
2636	Scalar::Util::weaken (my $widget = $self);	2722	Scalar::Util::weaken (my $widget = $self);
…		…
2695	$self->SUPER::DESTROY;	2781	$self->SUPER::DESTROY;
2696	}	2782	}
2697		2783
2698	#############################################################################	2784	#############################################################################
2699		2785
2700	package CFClient::UI::InventoryItem;
2701
2702	our @ISA = CFClient::UI::HBox::;
2703
2704	sub _item_to_desc {
2705	my ($item) = @_;
2706
2707	my $desc =
2708	$item->{nrof} < 2
2709	? $item->{name}
2710	: "$item->{nrof} × $item->{name_pl}";
2711
2712	$item->{flags} & Crossfire::Protocol::F_OPEN
2713	and $desc .= " (open)";
2714	$item->{flags} & Crossfire::Protocol::F_APPLIED
2715	and $desc .= " (applied)";
2716	$item->{flags} & Crossfire::Protocol::F_UNPAID
2717	and $desc .= " (unpaid)";
2718	$item->{flags} & Crossfire::Protocol::F_MAGIC
2719	and $desc .= " (magic)";
2720	$item->{flags} & Crossfire::Protocol::F_CURSED
2721	and $desc .= " (cursed)";
2722	$item->{flags} & Crossfire::Protocol::F_DAMNED
2723	and $desc .= " (damned)";
2724	$item->{flags} & Crossfire::Protocol::F_LOCKED
2725	and $desc .= " *";
2726
2727	$desc
2728	}
2729
2730	sub new {
2731	my $class = shift;
2732
2733	my %args = @_;
2734
2735	my $item = delete $args{item};
2736
2737	my $desc = _item_to_desc ($item);
2738
2739	my $self = $class->SUPER::new (
2740	can_hover => 1,
2741	can_events => 1,
2742	tooltip => ((CFClient::UI::Label::escape $desc)
2743	. "\n<small>leftclick - examine\nshift+leftclick - move/pickup/drop\nmiddle click - apply\nrightclick - menu</small>"),
2744	connect_button_down => sub {
2745	my ($self, $ev, $x, $y) = @_;
2746
2747	# todo: maybe put examine on 1? but should just be a tooltip :(
2748	if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
2749	my $targ = $::CONN->{player}{tag};
2750
2751	if ($item->{container} == $::CONN->{player}{tag}) {
2752	$targ = $main::OPENCONT;
2753	}
2754
2755	$::CONN->send ("move $targ $item->{tag} 0");
2756	} elsif ($ev->{button} == 1) {
2757	$::CONN->send ("examine $item->{tag}");
2758	} elsif ($ev->{button} == 2) {
2759	$::CONN->send ("apply $item->{tag}");
2760	} elsif ($ev->{button} == 3) {
2761	my @menu_items = (
2762	["examine", sub { $::CONN->send ("examine $item->{tag}") }],
2763	["mark", sub { $::CONN->send ("mark ". pack "N", $item->{tag}) }],
2764	["apply", sub { $::CONN->send ("apply $item->{tag}") }],
2765	(
2766	$item->{flags} & Crossfire::Protocol::F_LOCKED
2767	? (
2768	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $item->{tag}) }],
2769	)
2770	: (
2771	["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $item->{tag}) }],
2772	["drop", sub { $::CONN->send ("move $main::OPENCONT $item->{tag} 0") }],
2773	)
2774	),
2775	);
2776
2777	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
2778	}
2779
2780	1
2781	},
2782	%args
2783	);
2784
2785
2786	$self->add (new CFClient::UI::Face
2787	can_events => 0,
2788	face => $item->{face},
2789	anim => $item->{anim},
2790	animspeed => $item->{animspeed},
2791	);
2792
2793	$self->add ($self->{name_lbl} = new CFClient::UI::Label can_events => 0);
2794
2795	$self->{item} = $item;
2796
2797	$self->update_item;
2798
2799	$self
2800	}
2801
2802	sub update_item {
2803	my ($self) = @_;
2804
2805	my $desc = _item_to_desc ($self->{item});
2806
2807	$self->{name_lbl}->set_text ($desc);
2808	}
2809
2810	#############################################################################
2811
2812	package CFClient::UI::Inventory;
2813
2814	our @ISA = CFClient::UI::ScrolledWindow::;
2815
2816	sub new {
2817	my $class = shift;
2818
2819	my $self = $class->SUPER::new (
2820	scrolled => (new CFClient::UI::Table),
2821	@_,
2822	);
2823
2824	$self
2825	}
2826
2827	sub set_items {
2828	my ($self, $items) = @_;
2829
2830	$self->{scrolled}->clear;
2831	return unless $items;
2832
2833	my @items = sort {
2834	($a->{type} <=> $b->{type})
2835	or ($a->{name} cmp $b->{name})
2836	} @$items;
2837
2838	$self->{real_items} = \@items;
2839
2840	for my $item (@items) {
2841	$item->{item} = $item;
2842	$item = $item->{widget} ||= new CFClient::UI::InventoryItem item => $item;
2843	$item->update_item ();
2844	}
2845
2846	my $i = 0;
2847	for (@items) {
2848	$self->{scrolled}->add (0, $i, $_);
2849	my $nrof = $_->{item}->{nrof} || 1;
2850	$self->{scrolled}->add (1, $i++, new CFClient::UI::Label text => ($_->{item}->{weight} * $nrof) / 1000);
2851	}
2852
2853	# $range->{range} = [$self->{pos}, 0, $self->{max_pos}, $page];
2854	}
2855
2856	sub size_request {
2857	my ($self) = @_;
2858	($self->{req_w}, $self->{req_h});
2859	}
2860
2861	#############################################################################
2862
2863	package CFClient::UI::Menu;	2786	package CFClient::UI::Menu;
2864		2787
2865	our @ISA = CFClient::UI::FancyFrame::;	2788	our @ISA = CFClient::UI::FancyFrame::;
2866		2789
2867	use CFClient::OpenGL;	2790	use CFClient::OpenGL;
…		…
2905	# maybe save $GRAB? must be careful about events...	2828	# maybe save $GRAB? must be careful about events...
2906	$GRAB = $self;	2829	$GRAB = $self;
2907	$self->{button} = $ev->{button};	2830	$self->{button} = $ev->{button};
2908		2831
2909	$self->show;	2832	$self->show;
2910	$self->move ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);	2833	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);
2911	}	2834	}
2912		2835
2913	sub mouse_motion {	2836	sub mouse_motion {
2914	my ($self, $ev, $x, $y) = @_;	2837	my ($self, $ev, $x, $y) = @_;
2915		2838
…		…
2995	sub add {	2918	sub add {
2996	my ($self, $text, %arg) = @_;	2919	my ($self, $text, %arg) = @_;
2997		2920
2998	$text =~ s/^\s+//;	2921	$text =~ s/^\s+//;
2999	$text =~ s/\s+$//;	2922	$text =~ s/\s+$//;
		2923
		2924	return unless $text;
3000		2925
3001	my $timeout = time + ((delete $arg{timeout}) || 60);	2926	my $timeout = time + ((delete $arg{timeout}) || 60);
3002		2927
3003	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};	2928	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};
3004		2929
…		…
3038	$self->SUPER::reconfigure;	2963	$self->SUPER::reconfigure;
3039	}	2964	}
3040		2965
3041	#############################################################################	2966	#############################################################################
3042		2967
3043	package CFClient::UI::Root;	2968	package CFClient::UI::Inventory;
3044		2969
3045	our @ISA = CFClient::UI::Container::;	2970	our @ISA = CFClient::UI::ScrolledWindow::;
3046
3047	use CFClient::OpenGL;
3048		2971
3049	sub new {	2972	sub new {
3050	my $class = shift;	2973	my $class = shift;
3051		2974
3052	$class->SUPER::new (	2975	my $self = $class->SUPER::new (
		2976	scrolled => (new CFClient::UI::Table col_expand => [0, 1, 0]),
3053	@_,	2977	@_,
3054	)	2978	);
3055	}
3056		2979
3057	sub configure {	2980	$self
		2981	}
		2982
		2983	sub set_items {
		2984	my ($self, $items) = @_;
		2985
		2986	$self->{scrolled}->clear;
		2987	return unless $items;
		2988
		2989	my @items = sort {
		2990	($a->{type} <=> $b->{type})
		2991	or ($a->{name} cmp $b->{name})
		2992	} @$items;
		2993
		2994	$self->{real_items} = \@items;
		2995
		2996	my $row = 0;
		2997	for my $item (@items) {
		2998	CFClient::Item::update_widgets $item;
		2999
		3000	$self->{scrolled}->add (0, $row, $item->{face_widget});
		3001	$self->{scrolled}->add (1, $row, $item->{desc_widget});
		3002	$self->{scrolled}->add (2, $row, $item->{weight_widget});
		3003
		3004	$row++;
		3005	}
		3006	}
		3007
		3008	#############################################################################
		3009
		3010	package CFClient::UI::BindEditor;
		3011
		3012	our @ISA = CFClient::UI::FancyFrame::;
		3013
		3014	sub new {
		3015	my $class = shift;
		3016
		3017	my $self = $class->SUPER::new (binding => [], commands => [], @_);
		3018
		3019	$self->add (my $vb = new CFClient::UI::VBox);
		3020
		3021
		3022	$vb->add ($self->{rec_btn} = new CFClient::UI::Button
		3023	text => "start recording",
		3024	tooltip => "Start/Stops recording of actions."
		3025	."All subsequent actions after the recording started will be captured."
		3026	."The actions are displayed after the record was stopped."
		3027	."To bind the action you have to click on the 'Bind' button",
		3028	on_activate => sub {
		3029	unless ($self->{recording}) {
		3030	$self->start;
		3031	} else {
		3032	$self->stop;
		3033	}
		3034	});
		3035
		3036	$vb->add (new CFClient::UI::Label text => "Actions:");
		3037	$vb->add ($self->{cmdbox} = new CFClient::UI::VBox);
		3038
		3039	$vb->add (new CFClient::UI::Label text => "Bound to: ");
		3040	$vb->add (my $hb = new CFClient::UI::HBox);
		3041	$hb->add ($self->{keylbl} = new CFClient::UI::Label expand => 1);
		3042	$hb->add (new CFClient::UI::Button
		3043	text => "bind",
		3044	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
		3045	on_activate => sub {
		3046	$self->ask_for_bind;
		3047	});
		3048
		3049	$vb->add (my $hb = new CFClient::UI::HBox);
		3050	$hb->add (new CFClient::UI::Button
		3051	text => "ok",
		3052	expand => 1,
		3053	tooltip => "This closes the binding editor and saves the binding",
		3054	on_activate => sub {
		3055	$self->hide;
		3056	$self->commit;
		3057	});
		3058
		3059	$hb->add (new CFClient::UI::Button
		3060	text => "cancel",
		3061	expand => 1,
		3062	tooltip => "This closes the binding editor without saving",
		3063	on_activate => sub {
		3064	$self->hide;
		3065	$self->{binding_cancel}->()
		3066	if $self->{binding_cancel};
		3067	});
		3068
		3069	$self->update_binding_widgets;
		3070
		3071	$self
		3072	}
		3073
		3074	sub commit {
		3075	my ($self) = @_;
		3076	my ($mod, $sym, $cmds) = $self->get_binding;
		3077	if ($sym != 0 && @$cmds > 0) {
		3078	$::STATUSBOX->add ("Bound actions to '".CFClient::Binder::keycombo_to_name ($mod, $sym)
		3079	."'. Don't forget 'Save Config'!");
		3080	$self->{binding_change}->($mod, $sym, $cmds)
		3081	if $self->{binding_change};
		3082	} else {
		3083	$::STATUSBOX->add ("No action bound, no key or action specified!");
		3084	$self->{binding_cancel}->()
		3085	if $self->{binding_cancel};
		3086	}
		3087	}
		3088
		3089	sub start {
		3090	my ($self) = @_;
		3091
		3092	$self->{rec_btn}->set_text ("stop recording");
		3093	$self->{recording} = 1;
		3094	$self->clear_command_list;
		3095	$::CONN->start_record if $::CONN;
		3096	}
		3097
		3098	sub stop {
		3099	my ($self) = @_;
		3100
		3101	$self->{rec_btn}->set_text ("start recording");
		3102	$self->{recording} = 0;
		3103
		3104	my $rec;
		3105	$rec = $::CONN->stop_record if $::CONN;
		3106	return unless ref $rec eq 'ARRAY';
		3107	$self->set_command_list ($rec);
		3108	}
		3109
		3110	# if $commit is true, the binding will be set after the user entered a key combo
		3111	sub ask_for_bind {
		3112	my ($self, $commit) = @_;
		3113
		3114	CFClient::Binder::open_binding_dialog (sub {
		3115	my ($mod, $sym) = @_;
		3116	$self->{binding} = [$mod, $sym]; # XXX: how to stop that memleak?
		3117	$self->update_binding_widgets;
		3118	$self->commit if $commit;
		3119	});
		3120	}
		3121
		3122	# $mod and $sym are the modifiers and key symbol
		3123	# $cmds is a array ref of strings (the commands)
		3124	# $cb is the callback that is executed on OK
		3125	# $ccb is the callback that is executed on CANCEL and
		3126	# when the binding was unsuccessful on OK
		3127	sub set_binding {
3058	my ($self, $x, $y, $w, $h) = @_;	3128	my ($self, $mod, $sym, $cmds, $cb, $ccb) = @_;
3059		3129
3060	$self->{w} = $w;	3130	$self->clear_command_list;
3061	$self->{h} = $h;	3131	$self->{recording} = 0;
3062	}	3132	$self->{rec_btn}->set_text ("start recording");
3063		3133
3064	sub check_size {	3134	$self->{binding} = [$mod, $sym];
		3135	$self->{commands} = $cmds;
		3136
		3137	$self->{binding_change} = $cb;
		3138	$self->{binding_cancel} = $ccb;
		3139
		3140	$self->update_binding_widgets;
		3141	}
		3142
		3143	# this is a shortcut method that asks for a binding
		3144	# and then just binds it.
		3145	sub do_quick_binding {
3065	my ($self) = @_;	3146	my ($self, $cmds) = @_;
		3147	$self->set_binding (undef, undef, $cmds, sub {
		3148	$::CFG->{bindings}->{$_[0]}->{$_[1]} = $_[2];
		3149	});
		3150	$self->ask_for_bind (1);
		3151	}
3066		3152
3067	$self->size_allocate ($self->{w}, $self->{h})	3153	sub update_binding_widgets {
3068	if $self->{w};	3154	my ($self) = @_;
		3155	my ($mod, $sym, $cmds) = $self->get_binding;
		3156	$self->{keylbl}->set_text (CFClient::Binder::keycombo_to_name ($mod, $sym));
		3157	$self->set_command_list ($cmds);
		3158	}
		3159
		3160	sub get_binding {
		3161	my ($self) = @_;
		3162	return (
		3163	$self->{binding}->[0],
		3164	$self->{binding}->[1],
		3165	[ grep { defined $_ } @{$self->{commands}} ]
		3166	);
		3167	}
		3168
		3169	sub clear_command_list {
		3170	my ($self) = @_;
		3171	$self->{cmdbox}->clear ();
		3172	}
		3173
		3174	sub set_command_list {
		3175	my ($self, $cmds) = @_;
		3176
		3177	$self->{cmdbox}->clear ();
		3178	$self->{commands} = $cmds;
		3179
		3180	my $idx = 0;
		3181
		3182	for (@$cmds) {
		3183	$self->{cmdbox}->add (my $hb = new CFClient::UI::HBox);
		3184
		3185	my $i = $idx;
		3186	$hb->add (new CFClient::UI::Label text => $_);
		3187	$hb->add (new CFClient::UI::Button
		3188	text => "delete",
		3189	tooltip => "Deletes the action from the record",
		3190	on_activate => sub {
		3191	$self->{cmdbox}->remove ($hb);
		3192	$cmds->[$i] = undef;
		3193	});
		3194
		3195
		3196	$idx++
		3197	}
		3198	}
		3199
		3200	#############################################################################
		3201
		3202	package CFClient::UI::SpellList;
		3203
		3204	our @ISA = CFClient::UI::FancyFrame::;
		3205
		3206	sub new {
		3207	my $class = shift;
		3208
		3209	my $self = $class->SUPER::new (binding => [], commands => [], @_);
		3210
		3211	$self->add (new CFClient::UI::ScrolledWindow
		3212	scrolled => $self->{spellbox} = new CFClient::UI::Table);
		3213
		3214	$self;
		3215	}
		3216
		3217	# XXX: Do sorting? Argl...
		3218	sub add_spell {
		3219	my ($self, $spell) = @_;
		3220	$self->{spells}->{$spell->{name}} = $spell;
		3221
		3222	$self->{spellbox}->add (0, $self->{tbl_idx}, new CFClient::UI::Face
		3223	face => $spell->{face},
		3224	can_hover => 1,
		3225	can_events => 1,
		3226	tooltip => $spell->{message});
		3227
		3228	$self->{spellbox}->add (1, $self->{tbl_idx}, new CFClient::UI::Label
		3229	text => $spell->{name},
		3230	can_hover => 1,
		3231	can_events => 1,
		3232	tooltip => $spell->{message},
		3233	expand => 1);
		3234
		3235	$self->{spellbox}->add (2, $self->{tbl_idx}, new CFClient::UI::Label
		3236	text => (sprintf "lvl: %2d sp: %2d dmg: %2d",
		3237	$spell->{level}, ($spell->{mana} || $spell->{grace}), $spell->{damage}),
		3238	expand => 1);
		3239
		3240	$self->{spellbox}->add (3, $self->{tbl_idx}++, new CFClient::UI::Button
		3241	text => "bind to key",
		3242	on_activate => sub { $::BIND_EDITOR->do_quick_binding (["cast $spell->{name}"]) });
		3243	}
		3244
		3245	sub rebuild_spell_list {
		3246	my ($self) = @_;
		3247	$self->{tbl_idx} = 0;
		3248	$self->add_spell ($_) for values %{$self->{spells}};
		3249	}
		3250
		3251	sub remove_spell {
		3252	my ($self, $spell) = @_;
		3253	delete $self->{spells}->{$spell->{name}};
		3254	$self->rebuild_spell_list;
		3255	}
		3256
		3257	#############################################################################
		3258
		3259	package CFClient::UI::Root;
		3260
		3261	our @ISA = CFClient::UI::Container::;
		3262
		3263	use CFClient::OpenGL;
		3264
		3265	sub new {
		3266	my $class = shift;
		3267
		3268	my $self = $class->SUPER::new (
		3269	visible => 1,
		3270	@_,
		3271	);
		3272
		3273	Scalar::Util::weaken ($self->{root} = $self);
		3274
		3275	$self
3069	}	3276	}
3070		3277
3071	sub size_request {	3278	sub size_request {
3072	my ($self) = @_;	3279	my ($self) = @_;
3073		3280
3074	($self->{w}, $self->{h})	3281	($self->{w}, $self->{h})
		3282	}
		3283
		3284	sub _to_pixel {
		3285	my ($coord, $size, $max) = @_;
		3286
		3287	$coord =
		3288	$coord eq "center" ? ($max - $size) * 0.5
		3289	: $coord eq "max" ? $max
		3290	: $coord;
		3291
		3292	$coord = 0 if $coord < 0;
		3293	$coord = $max - $size if $coord > $max - $size;
		3294
		3295	int $coord + 0.5
3075	}	3296	}
3076		3297
3077	sub size_allocate {	3298	sub size_allocate {
3078	my ($self, $w, $h) = @_;	3299	my ($self, $w, $h) = @_;
3079		3300
3080	for my $child ($self->children) {	3301	for my $child ($self->children) {
3081	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};	3302	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};
3082		3303
3083	$X = $child->{req_x} > 0 ? $child->{req_x} : $w - $W - $child->{req_x} + 1	3304	$X = $child->{force_x} if exists $child->{force_x};
3084	if exists $child->{req_x};	3305	$Y = $child->{force_y} if exists $child->{force_y};
3085		3306
3086	$Y = $child->{req_y} > 0 ? $child->{req_y} : $h - $H - $child->{req_y} + 1	3307	$X = _to_pixel $X, $W, $self->{w};
3087	if exists $child->{req_y};	3308	$Y = _to_pixel $Y, $H, $self->{h};
3088
3089	$X = List::Util::max 0, List::Util::min $w - $W, int $X + 0.5;
3090	$Y = List::Util::max 0, List::Util::min $h - $H, int $Y + 0.5;
3091		3309
3092	$child->configure ($X, $Y, $W, $H);	3310	$child->configure ($X, $Y, $W, $H);
3093	}	3311	}
3094	}	3312	}
3095		3313
…		…
3106	}	3324	}
3107		3325
3108	sub update {	3326	sub update {
3109	my ($self) = @_;	3327	my ($self) = @_;
3110		3328
3111	$self->check_size;
3112	$::WANT_REFRESH++;	3329	$::WANT_REFRESH++;
3113	}	3330	}
3114		3331
3115	sub add {	3332	sub add {
3116	my ($self, @children) = @_;	3333	my ($self, @children) = @_;
3117		3334
3118	for (my @widgets = @children; my $w = pop @widgets; ) {
3119	push @widgets, $w->children;
3120	$w->{root} = $self;
3121	$w->{visible} = 1;
3122	}
3123
3124	for my $child (@children) {
3125	$child->{is_toplevel} = 1;	3335	$_->{is_toplevel} = 1
3126		3336	for @children;
3127	# integerise window positions
3128	$child->{x} = int $child->{x};
3129	$child->{y} = int $child->{y};
3130	}
3131		3337
3132	$self->SUPER::add (@children);	3338	$self->SUPER::add (@children);
3133	}	3339	}
3134		3340
3135	sub remove {	3341	sub remove {
3136	my ($self, @children) = @_;	3342	my ($self, @children) = @_;
3137		3343
3138	$self->SUPER::remove (@children);	3344	$self->SUPER::remove (@children);
		3345
		3346	delete $self->{is_toplevel}
		3347	for @children;
3139		3348
3140	while (@children) {	3349	while (@children) {
3141	my $w = pop @children;	3350	my $w = pop @children;
3142	push @children, $w->children;	3351	push @children, $w->children;
3143	$w->set_invisible;	3352	$w->set_invisible;
…		…
3162	while ($self->{refresh_hook}) {	3371	while ($self->{refresh_hook}) {
3163	$_->()	3372	$_->()
3164	for values %{delete $self->{refresh_hook}};	3373	for values %{delete $self->{refresh_hook}};
3165	}	3374	}
3166		3375
3167	if ($self->{check_size}) {	3376	if ($self->{realloc}) {
3168	my @queue = ([], []);	3377	my @queue;
3169		3378
3170	for (;;) {	3379	while () {
3171	if ($self->{check_size}) {	3380	if ($self->{realloc}) {
3172	# heuristic: check containers last	3381	#TODO use array-of-depth approach
3173	push @{ $queue[ ! ! $_->isa ("CFClient::UI::Container") ] }, $_	3382
3174	for values %{delete $self->{check_size}}	3383	use sort 'stable';
		3384
		3385	@queue = sort { $a->{visible} <=> $b->{visible} }
		3386	@queue, values %{delete $self->{realloc}};
3175	}	3387	}
3176		3388
3177	my $widget = (pop @{ $queue[0] }) || (pop @{ $queue[1] }) || last;	3389	my $widget = pop @queue || last;
3178		3390
3179	my ($w, $h) = $widget->{user_w} && $widget->{user_h}	3391	$widget->{visible} or last; # do not resize invisible widgets
3180	? @$widget{qw(user_w user_h)}	3392
3181	: $widget->size_request;	3393	my ($w, $h) = $widget->size_request;
3182		3394
		3395	$w = List::Util::max $widget->{min_w}, $w + $widget->{padding_x} * 2;
		3396	$h = List::Util::max $widget->{min_h}, $h + $widget->{padding_y} * 2;
		3397
		3398	$w = $widget->{force_w} if exists $widget->{force_w};
		3399	$h = $widget->{force_h} if exists $widget->{force_h};
		3400
		3401	if ($widget->{req_w} != $w || $widget->{req_h} != $h
3183	if (delete $widget->{force_alloc}	3402	|| delete $widget->{force_realloc}) {
3184	or $w != $widget->{req_w} or $h != $widget->{req_h}) {
3185	Carp::confess "$widget: size_request is negative" if $w < 0 || $h < 0;#d#
3186
3187	$widget->{req_w} = $w;	3403	$widget->{req_w} = $w;
3188	$widget->{req_h} = $h;	3404	$widget->{req_h} = $h;
3189		3405
3190	$self->{size_alloc}{$widget} = [$widget, $widget->{w} || $w, $widget->{h} || $h];	3406	$self->{size_alloc}{$widget+0} = $widget;
3191		3407
3192	$widget->{parent}->check_size
3193	if $widget->{parent};	3408	if (my $parent = $widget->{parent}) {
		3409	$self->{realloc}{$parent+0} = $parent;
		3410	#unshift @queue, $parent;
		3411	$parent->{force_size_alloc} = 1;
		3412	$self->{size_alloc}{$parent+0} = $parent;
		3413	}
3194	}	3414	}
		3415
		3416	delete $self->{realloc}{$widget+0};
3195	}	3417	}
3196	}	3418	}
3197		3419
3198	while ($self->{size_alloc}) {	3420	while (my $size_alloc = delete $self->{size_alloc}) {
3199	for (values %{delete $self->{size_alloc}}) {	3421	my @queue = sort { $b->{visible} <=> $a->{visible} }
3200	my ($widget, $w, $h) = @$_;	3422	values %$size_alloc;
		3423
		3424	while () {
		3425	my $widget = pop @queue || last;
		3426
		3427	my ($w, $h) = @$widget{qw(alloc_w alloc_h)};
3201		3428
3202	$w = 0 if $w < 0;	3429	$w = 0 if $w < 0;
3203	$h = 0 if $h < 0;	3430	$h = 0 if $h < 0;
3204		3431
		3432	$w = int $w + 0.5;
		3433	$h = int $h + 0.5;
		3434
		3435	if ($widget->{w} != $w || $widget->{h} != $h || delete $widget->{force_size_alloc}) {
3205	$widget->{w} = $w;	3436	$widget->{w} = $w;
3206	$widget->{h} = $h;	3437	$widget->{h} = $h;
		3438
3207	$widget->emit (size_allocate => $w, $h);	3439	$widget->emit (size_allocate => $w, $h);
		3440	}
3208	}	3441	}
3209	}	3442	}
3210		3443
3211	while ($self->{post_alloc_hook}) {	3444	while ($self->{post_alloc_hook}) {
3212	$_->()	3445	$_->()
3213	for values %{delete $self->{post_alloc_hook}};	3446	for values %{delete $self->{post_alloc_hook}};
3214	}	3447	}
		3448
3215		3449
3216	glViewport 0, 0, $::WIDTH, $::HEIGHT;	3450	glViewport 0, 0, $::WIDTH, $::HEIGHT;
3217	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	3451	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
3218	glClear GL_COLOR_BUFFER_BIT;	3452	glClear GL_COLOR_BUFFER_BIT;
3219		3453

Diff Legend

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