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.194 by root, Thu May 11 23:41:47 2006 UTC vs.
Revision 1.268 by root, Thu Jun 1 05:04:41 2006 UTC

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

Diff Legend

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