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.189 by root, Mon May 8 22:17:24 2006 UTC vs.
Revision 1.271 by root, Fri Jun 2 22:13:47 2006 UTC

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

Diff Legend

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