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.174 by root, Tue Apr 25 11:18:49 2006 UTC vs.
Revision 1.267 by root, Thu Jun 1 04:10:29 2006 UTC

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

Diff Legend

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