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.197 by root, Fri May 12 01:47:04 2006 UTC vs.
Revision 1.291 by root, Tue Jun 6 02:55:50 2006 UTC

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

Diff Legend

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