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

Diff Legend

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