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.203 by root, Sun May 14 21:13:11 2006 UTC vs.
Revision 1.272 by root, Sat Jun 3 01:47:14 2006 UTC

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

Diff Legend

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