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.157 by root, Sun Apr 23 21:47:32 2006 UTC vs.
Revision 1.264 by root, Thu Jun 1 02:58:30 2006 UTC

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

Diff Legend

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