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.233 by root, Thu May 25 03:42:40 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
238	CFClient::UI::check_tooltip	281	CFClient::UI::check_tooltip
239	if $CFClient::UI::TOOLTIP->{owner} == $self;	282	if $TOOLTIP->{owner} == $self;
240		283
241	$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;
242	}	304	}
243		305
244	sub hide {	306	sub hide {
245	my ($self) = @_;	307	my ($self) = @_;
246		308
…		…
248		310
249	$self->{parent}->remove ($self)	311	$self->{parent}->remove ($self)
250	if $self->{parent};	312	if $self->{parent};
251	}	313	}
252		314
253	sub move {	315	sub move_abs {
254	my ($self, $x, $y, $z) = @_;	316	my ($self, $x, $y, $z) = @_;
255		317
256	$self->{x} = int $x;	318	$self->{x} = List::Util::max 0, int $x;
257	$self->{y} = int $y;	319	$self->{y} = List::Util::max 0, int $y;
258	$self->{z} = $z if defined $z;	320	$self->{z} = $z if defined $z;
259		321
260	$self->update;	322	$self->update;
261	}	323	}
262		324
263	sub set_size {	325	sub set_size {
264	my ($self, $w, $h) = @_;	326	my ($self, $w, $h) = @_;
265		327
266	$self->{user_w} = $w;	328	$self->{force_w} = $w;
267	$self->{user_h} = $h;	329	$self->{force_h} = $h;
268		330
269	$self->check_size;	331	$self->realloc;
270	}	332	}
271		333
272	sub size_request {	334	sub size_request {
273	require Carp;	335	require Carp;
274	Carp::confess "size_request is abstract";	336	Carp::confess "size_request is abstract";
…		…
276		338
277	sub configure {	339	sub configure {
278	my ($self, $x, $y, $w, $h) = @_;	340	my ($self, $x, $y, $w, $h) = @_;
279		341
280	if ($self->{aspect}) {	342	if ($self->{aspect}) {
		343	my ($ow, $oh) = ($w, $h);
		344
281	my $w2 = List::Util::min $w, int $h * $self->{aspect};	345	$w = List::Util::min $w, int $h * $self->{aspect};
282	my $h2 = List::Util::min $h, int $w / $self->{aspect};	346	$h = List::Util::min $h, int $w / $self->{aspect};
283		347
284	# use alignment to adjust x, y	348	# use alignment to adjust x, y
285		349
286	$x += int +($w - $w2) * 0.5;	350	$x += int 0.5 * ($ow - $w);
287	$y += int +($h - $h2) * 0.5;	351	$y += int 0.5 * ($oh - $h);
288
289	($w, $h) = ($w2, $h2);
290	}	352	}
291		353
292	if ($self->{x} != $x || $self->{y} != $y) {	354	if ($self->{x} ne $x || $self->{y} ne $y) {
293	$self->{x} = $x;	355	$self->{x} = $x;
294	$self->{y} = $y;	356	$self->{y} = $y;
295	$self->update;	357	$self->update;
296	}	358	}
297		359
298	if ($self->{w} != $w || $self->{h} != $h) {	360	if ($self->{alloc_w} != $w || $self->{alloc_h} != $h) {
299	$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;
300	}	367	}
301	}	368	}
302		369
303	sub size_allocate {	370	sub size_allocate {
304	# nothing to be done	371	# nothing to be done
305	}	372	}
306		373
307	sub reconfigure {
308	my ($self) = @_;
309
310	$self->check_size (1);
311	$self->update;
312	}
313
314	sub children {	374	sub children {
315	}	375	}
316		376
317	sub set_max_size {	377	sub set_max_size {
318	my ($self, $w, $h) = @_;	378	my ($self, $w, $h) = @_;
…		…
321	delete $self->{max_h}; $self->{max_h} = $h if $h;	381	delete $self->{max_h}; $self->{max_h} = $h if $h;
322	}	382	}
323		383
324	sub set_tooltip {	384	sub set_tooltip {
325	my ($self, $tooltip) = @_;	385	my ($self, $tooltip) = @_;
		386
		387	$tooltip =~ s/^\s+//;
		388	$tooltip =~ s/\s+$//;
		389
		390	return if $self->{tooltip} eq $tooltip;
326		391
327	$self->{tooltip} = $tooltip;	392	$self->{tooltip} = $tooltip;
328		393
329	if ($CFClient::UI::TOOLTIP->{owner} == $self) {	394	if ($CFClient::UI::TOOLTIP->{owner} == $self) {
330	delete $CFClient::UI::TOOLTIP->{owner};	395	delete $CFClient::UI::TOOLTIP->{owner};
…		…
389	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }	454	sub w { $_[0]{w} = $_[1] if @_ > 1; $_[0]{w} }
390	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }	455	sub h { $_[0]{h} = $_[1] if @_ > 1; $_[0]{h} }
391	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }	456	sub x { $_[0]{x} = $_[1] if @_ > 1; $_[0]{x} }
392	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }	457	sub y { $_[0]{y} = $_[1] if @_ > 1; $_[0]{y} }
393	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	}
394		529
395	sub draw {	530	sub draw {
396	my ($self) = @_;	531	my ($self) = @_;
397		532
398	return unless $self->{h} && $self->{w};	533	return unless $self->{h} && $self->{w};
…		…
415	glVertex $x , $y + $self->{h};	550	glVertex $x , $y + $self->{h};
416	glEnd;	551	glEnd;
417	glDisable GL_BLEND;	552	glDisable GL_BLEND;
418	}	553	}
419		554
420	if ($ENV{PCLIENT_DEBUG}) {	555	if ($ENV{CFPLUS_DEBUG} & 1) {
421	glPushMatrix;	556	glPushMatrix;
422	glColor 1, 1, 0, 1;	557	glColor 1, 1, 0, 1;
423	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;	558	glTranslate $self->{x} + 0.375, $self->{y} + 0.375;
424	glBegin GL_LINE_LOOP;	559	glBegin GL_LINE_LOOP;
425	glVertex 0 , 0;	560	glVertex 0 , 0;
426	glVertex $self->{w}, 0;	561	glVertex $self->{w} - 1, 0;
427	glVertex $self->{w}, $self->{h};	562	glVertex $self->{w} - 1, $self->{h} - 1;
428	glVertex 0 , $self->{h};	563	glVertex 0 , $self->{h} - 1;
429	glEnd;	564	glEnd;
430	glPopMatrix;	565	glPopMatrix;
431	#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;
432	}	567	}
433	}	568	}
434		569
435	sub _draw {	570	sub _draw {
436	my ($self) = @_;	571	my ($self) = @_;
437		572
438	warn "no draw defined for $self\n";	573	warn "no draw defined for $self\n";
439	}
440
441	sub find_widget {
442	my ($self, $x, $y) = @_;
443
444	return () unless $self->{can_events};
445
446	return $self
447	if $x >= $self->{x} && $x < $self->{x} + $self->{w}
448	&& $y >= $self->{y} && $y < $self->{y} + $self->{h};
449
450	()
451	}
452
453	sub set_parent {
454	my ($self, $parent) = @_;
455
456	Scalar::Util::weaken ($self->{parent} = $parent);
457
458	# TODO: req_w _does_change after ->reconfigure
459	$self->check_size
460	unless exists $self->{req_w};
461
462	$self->show;
463	}
464
465	sub check_size {
466	my ($self, $forced) = @_;
467
468	$self->{force_alloc} = 1 if $forced;
469	$CFClient::UI::ROOT->{check_size}{$self} = $self;
470	}
471
472	sub update {
473	my ($self) = @_;
474
475	$self->{parent}->update
476	if $self->{parent};
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	}	574	}
497		575
498	sub DESTROY {	576	sub DESTROY {
499	my ($self) = @_;	577	my ($self) = @_;
500		578
…		…
558	my ($class, %arg) = @_;	636	my ($class, %arg) = @_;
559	$class->SUPER::new (can_events => 0, %arg);	637	$class->SUPER::new (can_events => 0, %arg);
560	}	638	}
561		639
562	sub size_request {	640	sub size_request {
563	(0, 0)	641	my ($self) = @_;
		642
		643	($self->{w} + 0, $self->{h} + 0)
564	}	644	}
565		645
566	sub draw { }	646	sub draw { }
567		647
568	#############################################################################	648	#############################################################################
…		…
597	$self->{children} = [	677	$self->{children} = [
598	sort { $a->{z} <=> $b->{z} }	678	sort { $a->{z} <=> $b->{z} }
599	@{$self->{children}}, @widgets	679	@{$self->{children}}, @widgets
600	];	680	];
601		681
602	$self->check_size (1);	682	$self->realloc;
603	$self->update;
604	}	683	}
605		684
606	sub children {	685	sub children {
607	@{ $_[0]{children} }	686	@{ $_[0]{children} }
608	}	687	}
…		…
613	delete $child->{parent};	692	delete $child->{parent};
614	$child->hide;	693	$child->hide;
615		694
616	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];	695	$self->{children} = [ grep $_ != $child, @{ $self->{children} } ];
617		696
618	$self->check_size;	697	$self->realloc;
619	$self->update;
620	}	698	}
621		699
622	sub clear {	700	sub clear {
623	my ($self) = @_;	701	my ($self) = @_;
624		702
…		…
628	for (@$children) {	706	for (@$children) {
629	delete $_->{parent};	707	delete $_->{parent};
630	$_->hide;	708	$_->hide;
631	}	709	}
632		710
633	$self->check_size;	711	$self->realloc;
634	$self->update;
635	}	712	}
636		713
637	sub find_widget {	714	sub find_widget {
638	my ($self, $x, $y) = @_;	715	my ($self, $x, $y) = @_;
639		716
…		…
763		840
764	package CFClient::UI::ViewPort;	841	package CFClient::UI::ViewPort;
765		842
766	our @ISA = CFClient::UI::Window::;	843	our @ISA = CFClient::UI::Window::;
767		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
768	sub size_request {	855	sub size_request {
769	my ($self) = @_;	856	my ($self) = @_;
770		857
771	@$self{qw(child_w child_h)} = @{$self->child}{qw(req_w req_h)};	858	my ($w, $h) = @{$self->child}{qw(req_w req_h)};
772		859
773	@$self{qw(child_w child_h)}	860	$w = 10 if $self->{scroll_x};
		861	$h = 10 if $self->{scroll_y};
		862
		863	($w, $h)
774	}	864	}
775		865
776	sub size_allocate {	866	sub size_allocate {
777	my ($self, $w, $h) = @_;	867	my ($self, $w, $h) = @_;
778		868
779	my ($cw, $ch) = @$self{qw(child_w child_h)};	869	my $child = $self->child;
780	# $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
781	$self->child->configure (0, 0, $cw, $ch);	874	$self->child->configure (0, 0, $w, $h);
782	$self->update;	875	$self->update;
783	}	876	}
784		877
785	sub set_offset {	878	sub set_offset {
786	my ($self, $x, $y) = @_;	879	my ($self, $x, $y) = @_;
…		…
837	my $class = shift;	930	my $class = shift;
838		931
839	my $self;	932	my $self;
840		933
841	my $slider = new CFClient::UI::Slider	934	my $slider = new CFClient::UI::Slider
842	vertical => 1,	935	vertical => 1,
843	range => [0, 0, 1, 0.01], # HACK fix	936	range => [0, 0, 1, 0.01], # HACK fix
844	connect_changed => sub {	937	on_changed => sub {
845	$self->{vp}->set_offset (0, $_[1]);	938	$self->{vp}->set_offset (0, $_[1]);
846	},	939	},
847	;	940	;
848		941
849	$self = $class->SUPER::new (	942	$self = $class->SUPER::new (
…		…
855	$self->{vp}->add ($self->{scrolled});	948	$self->{vp}->add ($self->{scrolled});
856	$self->add ($self->{vp});	949	$self->add ($self->{vp});
857	$self->add ($self->{slider});	950	$self->add ($self->{slider});
858		951
859	$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]);
860	}	963	}
861		964
862	sub size_allocate {	965	sub size_allocate {
863	my ($self, $w, $h) = @_;	966	my ($self, $w, $h) = @_;
864		967
…		…
917		1020
918	our @ISA = CFClient::UI::Bin::;	1021	our @ISA = CFClient::UI::Bin::;
919		1022
920	use CFClient::OpenGL;	1023	use CFClient::OpenGL;
921		1024
922	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 =
923	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }	1030	map { new_from_file CFClient::Texture CFClient::find_rcfile $_, mipmap => 1 }
924	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);
925		1032
926	sub new {	1033	sub new {
927	my $class = shift;	1034	my $class = shift;
928
929	# TODO: user_x, user_y, overwrite moveto?
930		1035
931	my $self = $class->SUPER::new (	1036	my $self = $class->SUPER::new (
932	bg => [1, 1, 1, 1],	1037	bg => [1, 1, 1, 1],
933	border_bg => [1, 1, 1, 1],	1038	border_bg => [1, 1, 1, 1],
934	border => 0.6,	1039	border => 0.6,
935	is_toplevel => 1,
936	can_events => 1,	1040	can_events => 1,
		1041	min_w => 16,
		1042	min_h => 16,
937	@_	1043	@_
938	);	1044	);
939		1045
940	$self->{title} &&= new CFClient::UI::Label	1046	$self->{title} &&= new CFClient::UI::Label
941	align => 0,	1047	align => 0,
…		…
994	my ($ev, $x, $y) = @_;	1100	my ($ev, $x, $y) = @_;
995		1101
996	my $dx = $ev->{x} - $ox;	1102	my $dx = $ev->{x} - $ox;
997	my $dy = $ev->{y} - $oy;	1103	my $dy = $ev->{y} - $oy;
998		1104
999	$self->{user_w} = $bw + $dx * ($mx ? -1 : 1);	1105	$self->{force_w} = $bw + $dx * ($mx ? -1 : 1);
1000	$self->{user_h} = $bh + $dy * ($my ? -1 : 1);	1106	$self->{force_h} = $bh + $dy * ($my ? -1 : 1);
		1107
		1108	$self->realloc;
1001	$self->move ($wx + $dx * $mx, $wy + $dy * $my);	1109	$self->move_abs ($wx + $dx * $mx, $wy + $dy * $my);
1002	$self->check_size;
1003	};	1110	};
1004		1111
1005	} elsif ($lr ^ $td) {	1112	} elsif ($lr ^ $td) {
1006	my ($ox, $oy) = ($ev->{x}, $ev->{y});	1113	my ($ox, $oy) = ($ev->{x}, $ev->{y});
1007	my ($bx, $by) = ($self->{x}, $self->{y});	1114	my ($bx, $by) = ($self->{x}, $self->{y});
…		…
1009	$self->{motion} = sub {	1116	$self->{motion} = sub {
1010	my ($ev, $x, $y) = @_;	1117	my ($ev, $x, $y) = @_;
1011		1118
1012	($x, $y) = ($ev->{x}, $ev->{y});	1119	($x, $y) = ($ev->{x}, $ev->{y});
1013		1120
1014	$self->move ($bx + $x - $ox, $by + $y - $oy);	1121	$self->move_abs ($bx + $x - $ox, $by + $y - $oy);
1015	$self->update;
1016	};	1122	};
1017	}	1123	}
1018	}	1124	}
1019		1125
1020	sub button_up {	1126	sub button_up {
…		…
1039	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;	1145	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE;
1040		1146
1041	my $border = $self->border;	1147	my $border = $self->border;
1042		1148
1043	glColor @{ $self->{border_bg} };	1149	glColor @{ $self->{border_bg} };
1044	$tex[1]->draw_quad_alpha (0, 0, $w, $border);	1150	$border[0]->draw_quad_alpha (0, 0, $w, $border);
1045	$tex[3]->draw_quad_alpha (0, $border, $border, $ch);	1151	$border[1]->draw_quad_alpha (0, $border, $border, $ch);
1046	$tex[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);	1152	$border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch);
1047	$tex[4]->draw_quad_alpha (0, $h - $border, $w, $border);	1153	$border[3]->draw_quad_alpha (0, $h - $border, $w, $border);
1048		1154
1049	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {	1155	if (@{$self->{bg}} < 4 || $self->{bg}[3]) {
1050	my $bg = $tex[0];	1156	glColor @{ $self->{bg} };
1051		1157
1052	# TODO: repeat texture not scale	1158	# TODO: repeat texture not scale
		1159	# solve this better(?)
1053	my $rep_x = $cw / $bg->{w};	1160	$bg->{s} = $cw / $bg->{w};
1054	my $rep_y = $ch / $bg->{h};	1161	$bg->{t} = $ch / $bg->{h};
1055
1056	glColor @{ $self->{bg} };
1057
1058	$bg->{s} = $rep_x;
1059	$bg->{t} = $rep_y;
1060	$bg->{wrap_mode} = 1;
1061	$bg->draw_quad_alpha ($border, $border, $cw, $ch);	1162	$bg->draw_quad_alpha ($border, $border, $cw, $ch);
1062	}	1163	}
1063		1164
1064	glDisable GL_TEXTURE_2D;	1165	glDisable GL_TEXTURE_2D;
1065		1166
…		…
1081	sub new {	1182	sub new {
1082	my $class = shift;	1183	my $class = shift;
1083		1184
1084	$class->SUPER::new (	1185	$class->SUPER::new (
1085	col_expand => [],	1186	col_expand => [],
1086	@_	1187	@_,
1087	)	1188	)
		1189	}
		1190
		1191	sub children {
		1192	grep $_, map @$_, grep $_, @{ $_[0]{children} }
1088	}	1193	}
1089		1194
1090	sub add {	1195	sub add {
1091	my ($self, $x, $y, $child) = @_;	1196	my ($self, $x, $y, $child) = @_;
1092		1197
1093	$child->set_parent ($self);	1198	$child->set_parent ($self);
1094	$self->{children}[$y][$x] = $child;	1199	$self->{children}[$y][$x] = $child;
1095		1200
1096	$child->check_size;	1201	$self->realloc;
1097	}	1202	}
1098		1203
1099	sub children {
1100	grep $_, map @$_, grep $_, @{ $_[0]{children} }
1101	}
1102
1103	# 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?
1104	sub clear {	1205	sub clear {
1105	my ($self) = @_;	1206	my ($self) = @_;
1106		1207
1107	my @children = $self->children;	1208	my @children = $self->children;
1108	delete $self->{children};	1209	delete $self->{children};
…		…
1110	for (@children) {	1211	for (@children) {
1111	delete $_->{parent};	1212	delete $_->{parent};
1112	$_->hide;	1213	$_->hide;
1113	}	1214	}
1114		1215
1115	$self->update;	1216	$self->realloc;
1116	}	1217	}
1117		1218
1118	sub get_wh {	1219	sub get_wh {
1119	my ($self) = @_;	1220	my ($self) = @_;
1120		1221
…		…
1151	sub size_allocate {	1252	sub size_allocate {
1152	my ($self, $w, $h) = @_;	1253	my ($self, $w, $h) = @_;
1153		1254
1154	my ($ws, $hs) = $self->get_wh;	1255	my ($ws, $hs) = $self->get_wh;
1155		1256
1156	my $req_w = sum @$ws;	1257	my $req_w = (sum @$ws) || 1;
1157	my $req_h = sum @$hs;	1258	my $req_h = (sum @$hs) || 1;
1158		1259
1159	# TODO: nicer code && do row_expand	1260	# TODO: nicer code && do row_expand
1160	my @col_expand = @{$self->{col_expand}};	1261	my @col_expand = @{$self->{col_expand}};
1161	@col_expand = (1) x @$ws unless @col_expand;	1262	@col_expand = (1) x @$ws unless @col_expand;
1162	my $col_expand = (sum @col_expand) || 1;	1263	my $col_expand = (sum @col_expand) || 1;
…		…
1216	}	1317	}
1217	}	1318	}
1218		1319
1219	#############################################################################	1320	#############################################################################
1220		1321
1221	package CFClient::UI::HBox;	1322	package CFClient::UI::Box;
1222
1223	# TODO: wrap into common Box base class
1224		1323
1225	our @ISA = CFClient::UI::Container::;	1324	our @ISA = CFClient::UI::Container::;
1226		1325
1227	sub size_request {	1326	sub size_request {
1228	my ($self) = @_;	1327	my ($self) = @_;
1229		1328
1230	my @alloc = map [$_->size_request], @{$self->{children}};	1329	$self->{vertical}
1231		1330	? (
1232	(	1331	(List::Util::max map $_->{req_w}, @{$self->{children}}),
1233	(List::Util::sum map $_->[0], @alloc),	1332	(List::Util::sum map $_->{req_h}, @{$self->{children}}),
1234	(List::Util::max map $_->[1], @alloc),	1333	)
1235	)	1334	: (
		1335	(List::Util::sum map $_->{req_w}, @{$self->{children}}),
		1336	(List::Util::max map $_->{req_h}, @{$self->{children}}),
		1337	)
1236	}	1338	}
1237		1339
1238	sub size_allocate {	1340	sub size_allocate {
1239	my ($self, $w, $h) = @_;	1341	my ($self, $w, $h) = @_;
1240		1342
1241	($h, $w) = ($w, $h);	1343	my $space = $self->{vertical} ? $h : $w;
1242
1243	my $children = $self->{children};	1344	my $children = $self->{children};
1244		1345
1245	my @h = map $_->{req_w}, @$children;	1346	my @req;
1246		1347
1247	my $req_h = List::Util::sum @h;	1348	if ($self->{homogeneous}) {
1248		1349	@req = ($space / (@$children || 1)) x @$children;
1249	if ($req_h > $h) {
1250	# ah well, not enough space
1251	$_ *= $h / $req_h for @h;
1252	} 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 {
1253	my $exp = List::Util::sum map $_->{expand}, @$children;	1358	my $expand = (List::Util::sum map $_->{expand}, @$children) || 1;
1254	$exp ||= 1;
1255		1359
		1360	$space = ($space - $req) / $expand; # remaining space to give away
		1361
		1362	$req[$_] += $space * $children->[$_]{expand}
1256	for (0 .. $#$children) {	1363	for 0 .. $#$children;
1257	my $child = $children->[$_];
1258
1259	my $alloc_h = $h[$_];
1260	$alloc_h += ($h - $req_h) * $child->{expand} / $exp;
1261	$h[$_] = $alloc_h;
1262	}	1364	}
1263	}	1365	}
1264		1366
1265	CFClient::UI::harmonize \@h;	1367	CFClient::UI::harmonize \@req;
1266		1368
1267	my $y = 0;	1369	my $pos = 0;
1268	for (0 .. $#$children) {	1370	for (0 .. $#$children) {
1269	my $child = $children->[$_];
1270	my $h = $h[$_];	1371	my $alloc = $req[$_];
1271	$child->configure ($y, 0, $h, $w);	1372	$children->[$_]->configure ($self->{vertical} ? (0, $pos, $w, $alloc) : ($pos, 0, $alloc, $h));
1272		1373
1273	$y += $h;	1374	$pos += $alloc;
1274	}	1375	}
1275		1376
1276	1	1377	1
1277	}	1378	}
1278		1379
1279	#############################################################################	1380	#############################################################################
1280		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
1281	package CFClient::UI::VBox;	1397	package CFClient::UI::VBox;
1282		1398
1283	# TODO: wrap into common Box base class
1284
1285	our @ISA = CFClient::UI::Container::;	1399	our @ISA = CFClient::UI::Box::;
1286		1400
1287	sub size_request {	1401	sub new {
1288	my ($self) = @_;	1402	my $class = shift;
1289		1403
1290	my @alloc = map [$_->size_request], @{$self->{children}};	1404	$class->SUPER::new (
1291		1405	vertical => 1,
1292	(	1406	@_,
1293	(List::Util::max map $_->[0], @alloc),
1294	(List::Util::sum map $_->[1], @alloc),
1295	)	1407	)
1296	}
1297
1298	sub size_allocate {
1299	my ($self, $w, $h) = @_;
1300
1301	Carp::confess "negative size" if $w < 0 || $h < 0;#d#
1302
1303	my $children = $self->{children};
1304
1305	my @h = map $_->{req_h}, @$children;
1306
1307	my $req_h = List::Util::sum @h;
1308
1309	if ($req_h > $h) {
1310	# ah well, not enough space
1311	$_ *= $h / $req_h for @h;
1312	} else {
1313	my $exp = List::Util::sum map $_->{expand}, @$children;
1314	$exp ||= 1;
1315
1316	for (0 .. $#$children) {
1317	my $child = $children->[$_];
1318
1319	$h[$_] += ($h - $req_h) * $child->{expand} / $exp;
1320	}
1321	}
1322
1323	CFClient::UI::harmonize \@h;
1324
1325	my $y = 0;
1326	for (0 .. $#$children) {
1327	my $child = $children->[$_];
1328	my $h = $h[$_];
1329	$child->configure (0, $y, $w, $h);
1330
1331	$y += $h;
1332	}
1333
1334	1
1335	}	1408	}
1336		1409
1337	#############################################################################	1410	#############################################################################
1338		1411
1339	package CFClient::UI::Label;	1412	package CFClient::UI::Label;
…		…
1356	ellipsise => 3, # end	1429	ellipsise => 3, # end
1357	layout => (new CFClient::Layout),	1430	layout => (new CFClient::Layout),
1358	fontsize => 1,	1431	fontsize => 1,
1359	align => -1,	1432	align => -1,
1360	valign => -1,	1433	valign => -1,
1361	padding => 2,	1434	padding_x => 2,
		1435	padding_y => 2,
1362	can_events => 0,	1436	can_events => 0,
1363	%arg	1437	%arg
1364	);	1438	);
1365		1439
1366	if (exists $self->{template}) {	1440	if (exists $self->{template}) {
…		…
1402	$self->{text} = "T$text";	1476	$self->{text} = "T$text";
1403		1477
1404	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;	1478	$self->{layout} = new CFClient::Layout if $self->{layout}->is_rgba;
1405	$self->{layout}->set_text ($text);	1479	$self->{layout}->set_text ($text);
1406		1480
		1481	$self->realloc;
1407	$self->update;	1482	$self->update;
1408	$self->check_size;
1409	}	1483	}
1410		1484
1411	sub set_markup {	1485	sub set_markup {
1412	my ($self, $markup) = @_;	1486	my ($self, $markup) = @_;
1413		1487
…		…
1417	my $rgba = $markup =~ /span.*(?:foreground|background)/;	1491	my $rgba = $markup =~ /span.*(?:foreground|background)/;
1418		1492
1419	$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;
1420	$self->{layout}->set_markup ($markup);	1494	$self->{layout}->set_markup ($markup);
1421		1495
		1496	$self->realloc;
1422	$self->update;	1497	$self->update;
1423	$self->check_size;
1424	}	1498	}
1425		1499
1426	sub size_request {	1500	sub size_request {
1427	my ($self) = @_;	1501	my ($self) = @_;
1428		1502
…		…
1442		1516
1443	$w = List::Util::max $w, $w2;	1517	$w = List::Util::max $w, $w2;
1444	$h = List::Util::max $h, $h2;	1518	$h = List::Util::max $h, $h2;
1445	}	1519	}
1446		1520
1447	(	1521	($w, $h)
1448	$w + $self->{padding} * 2,
1449	$h + $self->{padding} * 2,
1450	)
1451	}	1522	}
1452		1523
1453	sub size_allocate {	1524	sub size_allocate {
1454	my ($self, $w, $h) = @_;	1525	my ($self, $w, $h) = @_;
1455		1526
1456	delete $self->{texture};	1527	delete $self->{texture}
		1528	;#d#
1457	}	1529	}
1458		1530
1459	sub set_fontsize {	1531	sub set_fontsize {
1460	my ($self, $fontsize) = @_;	1532	my ($self, $fontsize) = @_;
1461		1533
1462	$self->{fontsize} = $fontsize;	1534	$self->{fontsize} = $fontsize;
1463	delete $self->{texture};	1535	delete $self->{texture};
1464		1536
1465	$self->update;	1537	$self->realloc;
1466	$self->check_size;
1467	}	1538	}
1468		1539
1469	sub _draw {	1540	sub _draw {
1470	my ($self) = @_;	1541	my ($self) = @_;
1471		1542
…		…
1479	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});	1550	$self->{layout}->set_single_paragraph_mode ($self->{ellipsise});
1480	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);	1551	$self->{layout}->set_height ($self->{fontsize} * $::FONTSIZE);
1481		1552
1482	my $tex = new_from_layout CFClient::Texture $self->{layout};	1553	my $tex = new_from_layout CFClient::Texture $self->{layout};
1483		1554
1484	$self->{ox} = int ($self->{align} < 0 ? $self->{padding}	1555	$self->{ox} = int ($self->{align} < 0 ? $self->{padding_x}
1485	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding}	1556	: $self->{align} > 0 ? $self->{w} - $tex->{w} - $self->{padding_x}
1486	: ($self->{w} - $tex->{w}) * 0.5);	1557	: ($self->{w} - $tex->{w}) * 0.5);
1487		1558
1488	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding}	1559	$self->{oy} = int ($self->{valign} < 0 ? $self->{padding_y}
1489	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding}	1560	: $self->{valign} > 0 ? $self->{h} - $tex->{h} - $self->{padding_y}
1490	: ($self->{h} - $tex->{h}) * 0.5);	1561	: ($self->{h} - $tex->{h}) * 0.5);
1491		1562
1492	$tex	1563	$tex
1493	};	1564	};
1494		1565
…		…
1551	sub set_text {	1622	sub set_text {
1552	my ($self, $text) = @_;	1623	my ($self, $text) = @_;
1553		1624
1554	$self->{cursor} = length $text;	1625	$self->{cursor} = length $text;
1555	$self->_set_text ($text);	1626	$self->_set_text ($text);
1556	$self->update;	1627
1557	$self->check_size;	1628	$self->realloc;
1558	}	1629	}
1559		1630
1560	sub get_text {	1631	sub get_text {
1561	$_[0]{text}	1632	$_[0]{text}
1562	}	1633	}
…		…
1595	} elsif ($uni) {	1666	} elsif ($uni) {
1596	substr $text, $self->{cursor}++, 0, chr $uni;	1667	substr $text, $self->{cursor}++, 0, chr $uni;
1597	}	1668	}
1598		1669
1599	$self->_set_text ($text);	1670	$self->_set_text ($text);
1600	$self->update;	1671
1601	$self->check_size;	1672	$self->realloc;
1602	}	1673	}
1603		1674
1604	sub focus_in {	1675	sub focus_in {
1605	my ($self) = @_;	1676	my ($self) = @_;
1606		1677
…		…
1733		1804
1734	sub new {	1805	sub new {
1735	my $class = shift;	1806	my $class = shift;
1736		1807
1737	$class->SUPER::new (	1808	$class->SUPER::new (
1738	padding => 4,	1809	padding_x => 4,
		1810	padding_y => 4,
1739	fg => [1, 1, 1],	1811	fg => [1, 1, 1],
1740	active_fg => [0, 0, 1],	1812	active_fg => [0, 0, 1],
1741	can_hover => 1,	1813	can_hover => 1,
1742	align => 0,	1814	align => 0,
1743	valign => 0,	1815	valign => 0,
…		…
1790		1862
1791	sub new {	1863	sub new {
1792	my $class = shift;	1864	my $class = shift;
1793		1865
1794	$class->SUPER::new (	1866	$class->SUPER::new (
1795	padding => 2,	1867	padding_x => 2,
		1868	padding_y => 2,
1796	fg => [1, 1, 1],	1869	fg => [1, 1, 1],
1797	active_fg => [1, 1, 0],	1870	active_fg => [1, 1, 0],
1798	bg => [0, 0, 0, 0.2],	1871	bg => [0, 0, 0, 0.2],
1799	active_bg => [1, 1, 1, 0.5],	1872	active_bg => [1, 1, 1, 0.5],
1800	state => 0,	1873	state => 0,
…		…
1804	}	1877	}
1805		1878
1806	sub size_request {	1879	sub size_request {
1807	my ($self) = @_;	1880	my ($self) = @_;
1808		1881
1809	($self->{padding} * 2 + 6) x 2	1882	(6) x 2
1810	}	1883	}
1811		1884
1812	sub button_down {	1885	sub button_down {
1813	my ($self, $ev, $x, $y) = @_;	1886	my ($self, $ev, $x, $y) = @_;
1814		1887
1815	if ($x >= $self->{padding} && $x < $self->{w} - $self->{padding}	1888	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1816	&& $y >= $self->{padding} && $y < $self->{h} - $self->{padding}) {	1889	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1817	$self->{state} = !$self->{state};	1890	$self->{state} = !$self->{state};
1818	$self->_emit (changed => $self->{state});	1891	$self->_emit (changed => $self->{state});
1819	}	1892	}
1820	}	1893	}
1821		1894
1822	sub _draw {	1895	sub _draw {
1823	my ($self) = @_;	1896	my ($self) = @_;
1824		1897
1825	$self->SUPER::_draw;	1898	$self->SUPER::_draw;
1826		1899
1827	glTranslate $self->{padding} + 0.375, $self->{padding} + 0.375, 0;	1900	glTranslate $self->{padding_x} + 0.375, $self->{padding_y} + 0.375, 0;
1828		1901
1829	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;
1830		1905
1831	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };	1906	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };
1832		1907
1833	my $tex = $self->{state} ? $tex[1] : $tex[0];	1908	my $tex = $self->{state} ? $tex[1] : $tex[0];
1834		1909
…		…
2099	fg => [1, 1, 1],	2174	fg => [1, 1, 1],
2100	active_fg => [0, 0, 0],	2175	active_fg => [0, 0, 0],
2101	bg => [0, 0, 0, 0.2],	2176	bg => [0, 0, 0, 0.2],
2102	active_bg => [1, 1, 1, 0.5],	2177	active_bg => [1, 1, 1, 0.5],
2103	range => [0, 0, 100, 10, 0],	2178	range => [0, 0, 100, 10, 0],
2104	req_w => $::WIDTH / 80,	2179	min_w => $::WIDTH / 80,
2105	req_h => $::WIDTH / 80,	2180	min_h => $::WIDTH / 80,
2106	vertical => 0,	2181	vertical => 0,
2107	can_hover => 1,	2182	can_hover => 1,
2108	inner_pad => 0.02,	2183	inner_pad => 0.02,
2109	@_	2184	@_
2110	);	2185	);
…		…
2113	$self->update;	2188	$self->update;
2114		2189
2115	$self	2190	$self
2116	}	2191	}
2117		2192
		2193	sub changed { }
		2194
2118	sub set_range {	2195	sub set_range {
2119	my ($self, $range) = @_;	2196	my ($self, $range) = @_;
2120		2197
2121	$self->{range} = $range;	2198	($range, $self->{range}) = ($self->{range}, $range);
2122		2199
2123	$self->update;	2200	$self->update
		2201	if "@$range" ne "@{$self->{range}}";
2124	}	2202	}
2125		2203
2126	sub set_value {	2204	sub set_value {
2127	my ($self, $value) = @_;	2205	my ($self, $value) = @_;
2128		2206
…		…
2147	}	2225	}
2148		2226
2149	sub size_request {	2227	sub size_request {
2150	my ($self) = @_;	2228	my ($self) = @_;
2151		2229
2152	my $w = $self->{req_w};	2230	($self->{req_w}, $self->{req_h})
2153	my $h = $self->{req_h};
2154
2155	$self->{vertical} ? ($h, $w) : ($w, $h)
2156	}	2231	}
2157		2232
2158	sub button_down {	2233	sub button_down {
2159	my ($self, $ev, $x, $y) = @_;	2234	my ($self, $ev, $x, $y) = @_;
2160		2235
…		…
2511		2586
2512	sub new {	2587	sub new {
2513	my $class = shift;	2588	my $class = shift;
2514		2589
2515	my $self = $class->SUPER::new (	2590	my $self = $class->SUPER::new (
2516	state => 0,	2591	state => 0,
2517	connect_activate => \&toggle_flopper,	2592	on_activate => \&toggle_flopper,
2518	@_	2593	@_
2519	);	2594	);
2520		2595
2521	if ($self->{state}) {
2522	$self->{state} = 0;
2523	$self->toggle_flopper;
2524	}
2525
2526	$self	2596	$self
2527	}	2597	}
2528		2598
2529	sub toggle_flopper {	2599	sub toggle_flopper {
2530	my ($self) = @_;	2600	my ($self) = @_;
2531		2601
2532	# TODO: use animation	2602	$self->{other}->toggle_visibility;
2533	if ($self->{state} = !$self->{state}) {
2534	$CFClient::UI::ROOT->add ($self->{other});
2535	$self->{other}->move ($self->coord2global (0, $self->{h}));
2536	$self->_emit ("open");
2537	} else {
2538	$CFClient::UI::ROOT->remove ($self->{other});
2539	$self->_emit ("close");
2540	}
2541
2542	$self->_emit (changed => $self->{state});
2543	}	2603	}
2544		2604
2545	#############################################################################	2605	#############################################################################
2546		2606
2547	package CFClient::UI::Tooltip;	2607	package CFClient::UI::Tooltip;
…		…
2560	}	2620	}
2561		2621
2562	sub set_tooltip_from {	2622	sub set_tooltip_from {
2563	my ($self, $widget) = @_;	2623	my ($self, $widget) = @_;
2564		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
2565	$self->add (new CFClient::UI::Label	2634	$self->add (new CFClient::UI::Label
2566	markup => $widget->{tooltip},	2635	markup => $tooltip,
2567	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,	2636	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
2568	fontsize => 0.8,	2637	fontsize => 0.8,
2569	fg => [0, 0, 0, 1],	2638	fg => [0, 0, 0, 1],
2570	ellipsise => 0,	2639	ellipsise => 0,
2571	font => ($widget->{tooltip_font} || $::FONT_PROP),	2640	font => ($widget->{tooltip_font} || $::FONT_PROP),
…		…
2582		2651
2583	sub size_allocate {	2652	sub size_allocate {
2584	my ($self, $w, $h) = @_;	2653	my ($self, $w, $h) = @_;
2585		2654
2586	$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	});
2587	}	2674	}
2588		2675
2589	sub _draw {	2676	sub _draw {
2590	my ($self) = @_;	2677	my ($self) = @_;
2591		2678
…		…
2608	glVertex $w, $h;	2695	glVertex $w, $h;
2609	glVertex $w, 0;	2696	glVertex $w, 0;
2610	glEnd;	2697	glEnd;
2611		2698
2612	glTranslate 2 - 0.375, 2 - 0.375;	2699	glTranslate 2 - 0.375, 2 - 0.375;
		2700
2613	$self->SUPER::_draw;	2701	$self->SUPER::_draw;
2614	}	2702	}
2615		2703
2616	#############################################################################	2704	#############################################################################
2617		2705
…		…
2623		2711
2624	sub new {	2712	sub new {
2625	my $class = shift;	2713	my $class = shift;
2626		2714
2627	my $self = $class->SUPER::new (	2715	my $self = $class->SUPER::new (
2628	aspect => 1,	2716	aspect => 1,
		2717	can_events => 0,
2629	@_,	2718	@_,
2630	);	2719	);
2631		2720
2632	if ($self->{anim} && $self->{animspeed}) {	2721	if ($self->{anim} && $self->{animspeed}) {
2633	Scalar::Util::weaken (my $widget = $self);	2722	Scalar::Util::weaken (my $widget = $self);
…		…
2692	$self->SUPER::DESTROY;	2781	$self->SUPER::DESTROY;
2693	}	2782	}
2694		2783
2695	#############################################################################	2784	#############################################################################
2696		2785
2697	package CFClient::UI::InventoryItem;
2698
2699	our @ISA = CFClient::UI::HBox::;
2700
2701	sub _item_to_desc {
2702	my ($item) = @_;
2703
2704	my $desc =
2705	$item->{nrof} < 2
2706	? $item->{name}
2707	: "$item->{nrof} × $item->{name_pl}";
2708
2709	$item->{flags} & Crossfire::Protocol::F_OPEN
2710	and $desc .= " (open)";
2711	$item->{flags} & Crossfire::Protocol::F_APPLIED
2712	and $desc .= " (applied)";
2713	$item->{flags} & Crossfire::Protocol::F_UNPAID
2714	and $desc .= " (unpaid)";
2715	$item->{flags} & Crossfire::Protocol::F_MAGIC
2716	and $desc .= " (magic)";
2717	$item->{flags} & Crossfire::Protocol::F_CURSED
2718	and $desc .= " (cursed)";
2719	$item->{flags} & Crossfire::Protocol::F_DAMNED
2720	and $desc .= " (damned)";
2721	$item->{flags} & Crossfire::Protocol::F_LOCKED
2722	and $desc .= " *";
2723
2724	$desc
2725	}
2726
2727	sub new {
2728	my $class = shift;
2729
2730	my %args = @_;
2731
2732	my $item = delete $args{item};
2733
2734	my $desc = _item_to_desc ($item);
2735
2736	my $self = $class->SUPER::new (
2737	can_hover => 1,
2738	can_events => 1,
2739	tooltip => ((CFClient::UI::Label::escape $desc)
2740	. "\n<small>leftclick - examine\nshift+leftclick - move/pickup/drop\nmiddle click - apply\nrightclick - menu</small>"),
2741	connect_button_down => sub {
2742	my ($self, $ev, $x, $y) = @_;
2743
2744	# todo: maybe put examine on 1? but should just be a tooltip :(
2745	if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
2746	my $targ = $::CONN->{player}{tag};
2747
2748	if ($item->{container} == $::CONN->{player}{tag}) {
2749	$targ = $main::OPENCONT;
2750	}
2751
2752	$::CONN->send ("move $targ $item->{tag} 0");
2753	} elsif ($ev->{button} == 1) {
2754	$::CONN->send ("examine $item->{tag}");
2755	} elsif ($ev->{button} == 2) {
2756	$::CONN->send ("apply $item->{tag}");
2757	} elsif ($ev->{button} == 3) {
2758	my @menu_items = (
2759	["examine", sub { $::CONN->send ("examine $item->{tag}") }],
2760	["mark", sub { $::CONN->send ("mark ". pack "N", $item->{tag}) }],
2761	["apply", sub { $::CONN->send ("apply $item->{tag}") }],
2762	(
2763	$item->{flags} & Crossfire::Protocol::F_LOCKED
2764	? (
2765	["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $item->{tag}) }],
2766	)
2767	: (
2768	["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $item->{tag}) }],
2769	["drop", sub { $::CONN->send ("move $main::OPENCONT $item->{tag} 0") }],
2770	)
2771	),
2772	);
2773
2774	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
2775	}
2776
2777	1
2778	},
2779	%args
2780	);
2781
2782
2783	$self->add (new CFClient::UI::Face
2784	can_events => 0,
2785	face => $item->{face},
2786	anim => $item->{anim},
2787	animspeed => $item->{animspeed},
2788	);
2789
2790	$self->add ($self->{name_lbl} = new CFClient::UI::Label can_events => 0);
2791
2792	$self->{item} = $item;
2793
2794	$self->update_item;
2795
2796	$self
2797	}
2798
2799	sub update_item {
2800	my ($self) = @_;
2801
2802	my $desc = _item_to_desc ($self->{item});
2803
2804	$self->{name_lbl}->set_text ($desc);
2805	}
2806
2807	#############################################################################
2808
2809	package CFClient::UI::Inventory;
2810
2811	our @ISA = CFClient::UI::ScrolledWindow::;
2812
2813	sub new {
2814	my $class = shift;
2815
2816	my $self = $class->SUPER::new (
2817	scrolled => (new CFClient::UI::Table),
2818	@_,
2819	);
2820
2821	$self
2822	}
2823
2824	sub set_items {
2825	my ($self, $items) = @_;
2826
2827	$self->{scrolled}->clear;
2828	return unless $items;
2829
2830	my @items = sort {
2831	($a->{type} <=> $b->{type})
2832	or ($a->{name} cmp $b->{name})
2833	} @$items;
2834
2835	$self->{real_items} = \@items;
2836
2837	for my $item (@items) {
2838	$item->{item} = $item;
2839	$item = $item->{widget} ||= new CFClient::UI::InventoryItem item => $item;
2840	$item->update_item ();
2841	}
2842
2843	my $i = 0;
2844	for (@items) {
2845	$self->{scrolled}->add (0, $i, $_);
2846	my $nrof = $_->{item}->{nrof} || 1;
2847	$self->{scrolled}->add (1, $i++, new CFClient::UI::Label text => ($_->{item}->{weight} * $nrof) / 1000);
2848	}
2849
2850	# $range->{range} = [$self->{pos}, 0, $self->{max_pos}, $page];
2851	}
2852
2853	sub size_request {
2854	my ($self) = @_;
2855	($self->{req_w}, $self->{req_h});
2856	}
2857
2858	#############################################################################
2859
2860	package CFClient::UI::Menu;	2786	package CFClient::UI::Menu;
2861		2787
2862	our @ISA = CFClient::UI::FancyFrame::;	2788	our @ISA = CFClient::UI::FancyFrame::;
2863		2789
2864	use CFClient::OpenGL;	2790	use CFClient::OpenGL;
…		…
2902	# maybe save $GRAB? must be careful about events...	2828	# maybe save $GRAB? must be careful about events...
2903	$GRAB = $self;	2829	$GRAB = $self;
2904	$self->{button} = $ev->{button};	2830	$self->{button} = $ev->{button};
2905		2831
2906	$self->show;	2832	$self->show;
2907	$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);
2908	}	2834	}
2909		2835
2910	sub mouse_motion {	2836	sub mouse_motion {
2911	my ($self, $ev, $x, $y) = @_;	2837	my ($self, $ev, $x, $y) = @_;
2912		2838
…		…
3037	$self->SUPER::reconfigure;	2963	$self->SUPER::reconfigure;
3038	}	2964	}
3039		2965
3040	#############################################################################	2966	#############################################################################
3041		2967
3042	package CFClient::UI::Root;	2968	package CFClient::UI::Inventory;
3043		2969
3044	our @ISA = CFClient::UI::Container::;	2970	our @ISA = CFClient::UI::ScrolledWindow::;
3045
3046	use CFClient::OpenGL;
3047		2971
3048	sub new {	2972	sub new {
3049	my $class = shift;	2973	my $class = shift;
3050		2974
3051	$class->SUPER::new (	2975	my $self = $class->SUPER::new (
		2976	scrolled => (new CFClient::UI::Table col_expand => [0, 1, 0]),
3052	@_,	2977	@_,
3053	)	2978	);
3054	}
3055		2979
3056	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 {
3057	my ($self, $x, $y, $w, $h) = @_;	3128	my ($self, $mod, $sym, $cmds, $cb, $ccb) = @_;
3058		3129
3059	$self->{w} = $w;	3130	$self->clear_command_list;
3060	$self->{h} = $h;	3131	$self->{recording} = 0;
3061	}	3132	$self->{rec_btn}->set_text ("start recording");
3062		3133
3063	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 {
3064	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	}
3065		3152
3066	$self->size_allocate ($self->{w}, $self->{h})	3153	sub update_binding_widgets {
3067	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
3068	}	3276	}
3069		3277
3070	sub size_request {	3278	sub size_request {
3071	my ($self) = @_;	3279	my ($self) = @_;
3072		3280
3073	($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
3074	}	3296	}
3075		3297
3076	sub size_allocate {	3298	sub size_allocate {
3077	my ($self, $w, $h) = @_;	3299	my ($self, $w, $h) = @_;
3078		3300
3079	for my $child ($self->children) {	3301	for my $child ($self->children) {
3080	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)};
3081		3303
3082	$X = $child->{req_x} > 0 ? $child->{req_x} : $w - $W - $child->{req_x} + 1	3304	$X = $child->{force_x} if exists $child->{force_x};
3083	if exists $child->{req_x};	3305	$Y = $child->{force_y} if exists $child->{force_y};
3084		3306
3085	$Y = $child->{req_y} > 0 ? $child->{req_y} : $h - $H - $child->{req_y} + 1	3307	$X = _to_pixel $X, $W, $self->{w};
3086	if exists $child->{req_y};	3308	$Y = _to_pixel $Y, $H, $self->{h};
3087
3088	$X = List::Util::max 0, List::Util::min $w - $W, int $X + 0.5;
3089	$Y = List::Util::max 0, List::Util::min $h - $H, int $Y + 0.5;
3090		3309
3091	$child->configure ($X, $Y, $W, $H);	3310	$child->configure ($X, $Y, $W, $H);
3092	}	3311	}
3093	}	3312	}
3094		3313
…		…
3105	}	3324	}
3106		3325
3107	sub update {	3326	sub update {
3108	my ($self) = @_;	3327	my ($self) = @_;
3109		3328
3110	$self->check_size;
3111	$::WANT_REFRESH++;	3329	$::WANT_REFRESH++;
3112	}	3330	}
3113		3331
3114	sub add {	3332	sub add {
3115	my ($self, @children) = @_;	3333	my ($self, @children) = @_;
3116		3334
3117	for (my @widgets = @children; my $w = pop @widgets; ) {
3118	push @widgets, $w->children;
3119	$w->{root} = $self;
3120	$w->{visible} = 1;
3121	}
3122
3123	for my $child (@children) {
3124	$child->{is_toplevel} = 1;	3335	$_->{is_toplevel} = 1
3125		3336	for @children;
3126	# integerise window positions
3127	$child->{x} = int $child->{x};
3128	$child->{y} = int $child->{y};
3129	}
3130		3337
3131	$self->SUPER::add (@children);	3338	$self->SUPER::add (@children);
3132	}	3339	}
3133		3340
3134	sub remove {	3341	sub remove {
3135	my ($self, @children) = @_;	3342	my ($self, @children) = @_;
3136		3343
3137	$self->SUPER::remove (@children);	3344	$self->SUPER::remove (@children);
		3345
		3346	delete $self->{is_toplevel}
		3347	for @children;
3138		3348
3139	while (@children) {	3349	while (@children) {
3140	my $w = pop @children;	3350	my $w = pop @children;
3141	push @children, $w->children;	3351	push @children, $w->children;
3142	$w->set_invisible;	3352	$w->set_invisible;
…		…
3161	while ($self->{refresh_hook}) {	3371	while ($self->{refresh_hook}) {
3162	$_->()	3372	$_->()
3163	for values %{delete $self->{refresh_hook}};	3373	for values %{delete $self->{refresh_hook}};
3164	}	3374	}
3165		3375
3166	if ($self->{check_size}) {	3376	if ($self->{realloc}) {
3167	my @queue = ([], []);	3377	my @queue;
3168		3378
3169	for (;;) {	3379	while () {
3170	if ($self->{check_size}) {	3380	if ($self->{realloc}) {
3171	# heuristic: check containers last	3381	#TODO use array-of-depth approach
3172	push @{ $queue[ ! ! $_->isa ("CFClient::UI::Container") ] }, $_	3382
3173	for values %{delete $self->{check_size}}	3383	use sort 'stable';
		3384
		3385	@queue = sort { $a->{visible} <=> $b->{visible} }
		3386	@queue, values %{delete $self->{realloc}};
3174	}	3387	}
3175		3388
3176	my $widget = (pop @{ $queue[0] }) || (pop @{ $queue[1] }) || last;	3389	my $widget = pop @queue || last;
3177		3390
3178	my ($w, $h) = $widget->{user_w} && $widget->{user_h}	3391	$widget->{visible} or last; # do not resize invisible widgets
3179	? @$widget{qw(user_w user_h)}	3392
3180	: $widget->size_request;	3393	my ($w, $h) = $widget->size_request;
3181		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
3182	if (delete $widget->{force_alloc}	3402	|| delete $widget->{force_realloc}) {
3183	or $w != $widget->{req_w} or $h != $widget->{req_h}) {
3184	Carp::confess "$widget: size_request is negative" if $w < 0 || $h < 0;#d#
3185
3186	$widget->{req_w} = $w;	3403	$widget->{req_w} = $w;
3187	$widget->{req_h} = $h;	3404	$widget->{req_h} = $h;
3188		3405
3189	$self->{size_alloc}{$widget} = [$widget, $widget->{w} || $w, $widget->{h} || $h];	3406	$self->{size_alloc}{$widget+0} = $widget;
3190		3407
3191	$widget->{parent}->check_size
3192	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	}
3193	}	3414	}
		3415
		3416	delete $self->{realloc}{$widget+0};
3194	}	3417	}
3195	}	3418	}
3196		3419
3197	while ($self->{size_alloc}) {	3420	while (my $size_alloc = delete $self->{size_alloc}) {
3198	for (values %{delete $self->{size_alloc}}) {	3421	my @queue = sort { $b->{visible} <=> $a->{visible} }
3199	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)};
3200		3428
3201	$w = 0 if $w < 0;	3429	$w = 0 if $w < 0;
3202	$h = 0 if $h < 0;	3430	$h = 0 if $h < 0;
3203		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}) {
3204	$widget->{w} = $w;	3436	$widget->{w} = $w;
3205	$widget->{h} = $h;	3437	$widget->{h} = $h;
		3438
3206	$widget->emit (size_allocate => $w, $h);	3439	$widget->emit (size_allocate => $w, $h);
		3440	}
3207	}	3441	}
3208	}	3442	}
3209		3443
3210	while ($self->{post_alloc_hook}) {	3444	while ($self->{post_alloc_hook}) {
3211	$_->()	3445	$_->()
3212	for values %{delete $self->{post_alloc_hook}};	3446	for values %{delete $self->{post_alloc_hook}};
3213	}	3447	}
		3448
3214		3449
3215	glViewport 0, 0, $::WIDTH, $::HEIGHT;	3450	glViewport 0, 0, $::WIDTH, $::HEIGHT;
3216	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	3451	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
3217	glClear GL_COLOR_BUFFER_BIT;	3452	glClear GL_COLOR_BUFFER_BIT;
3218		3453

Diff Legend

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