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.291 by root, Tue Jun 6 02:55:50 2006 UTC

…		…
3	use utf8;	3	use utf8;
4	use strict;	4	use strict;
5		5
6	use Scalar::Util ();	6	use Scalar::Util ();
7	use List::Util ();	7	use List::Util ();
		8	use Event;
8		9
9	use CFClient;	10	use CFClient;
		11	use CFClient::Texture;
10		12
11	our ($FOCUS, $HOVER, $GRAB); # various widgets	13	our ($FOCUS, $HOVER, $GRAB); # various widgets
12		14
		15	our $LAYOUT;
13	our $ROOT;	16	our $ROOT;
14	our $TOOLTIP;	17	our $TOOLTIP;
15	our $BUTTON_STATE;	18	our $BUTTON_STATE;
16		19
17	sub check_tooltip {	20	our %WIDGET; # all widgets, weak-referenced
		21
		22	our $TOOLTIP_WATCHER = Event->idle (min => 1/60, cb => sub {
18	if (!$GRAB) {	23	if (!$GRAB) {
19	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {	24	for (my $widget = $HOVER; $widget; $widget = $widget->{parent}) {
20	if (length $widget->{tooltip}) {	25	if (length $widget->{tooltip}) {
21
22	if ($TOOLTIP->{owner} != $widget) {	26	if ($TOOLTIP->{owner} != $widget) {
		27	$TOOLTIP->hide;
		28
23	$TOOLTIP->{owner} = $widget;	29	$TOOLTIP->{owner} = $widget;
		30
		31	return if $ENV{CFPLUS_DEBUG} & 8;
24		32
25	my $tip = $widget->{tooltip};	33	my $tip = $widget->{tooltip};
26		34
27	$tip = $tip->($widget) if CODE:: eq ref $tip;	35	$tip = $tip->($widget) if CODE:: eq ref $tip;
28		36
29	$TOOLTIP->set_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 => ...
		1696	#hidden => "*",
1433	@_	1697	@_
1434	)	1698	)
1435	}	1699	}
1436		1700
1437	sub _set_text {	1701	sub _set_text {
…		…
1439		1703
1440	delete $self->{cur_h};	1704	delete $self->{cur_h};
1441		1705
1442	return if $self->{text} eq $text;	1706	return if $self->{text} eq $text;
1443		1707
1444	delete $self->{texture};
1445
1446	$self->{last_activity} = $::NOW;	1708	$self->{last_activity} = $::NOW;
1447	$self->{text} = $text;	1709	$self->{text} = $text;
1448		1710
1449	$text =~ s/./*/g if $self->{hidden};	1711	$text =~ s/./*/g if $self->{hidden};
1450	$self->{layout}->set_text ("$text ");	1712	$self->{layout}->set_text ("$text ");
		1713	delete $self->{size_req};
1451		1714
1452	$self->emit (changed => $self->{text});	1715	$self->_emit (changed => $self->{text});
		1716
		1717	$self->realloc;
		1718	$self->update;
1453	}	1719	}
1454		1720
1455	sub set_text {	1721	sub set_text {
1456	my ($self, $text) = @_;	1722	my ($self, $text) = @_;
1457		1723
1458	$self->{cursor} = length $text;	1724	$self->{cursor} = length $text;
1459	$self->_set_text ($text);	1725	$self->_set_text ($text);
1460	$self->check_size;
1461	$self->update;
1462	}	1726	}
1463		1727
1464	sub get_text {	1728	sub get_text {
1465	$_[0]{text}	1729	$_[0]{text}
1466	}	1730	}
…		…
1469	my ($self) = @_;	1733	my ($self) = @_;
1470		1734
1471	my ($w, $h) = $self->SUPER::size_request;	1735	my ($w, $h) = $self->SUPER::size_request;
1472		1736
1473	($w + 1, $h) # add 1 for cursor	1737	($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	}	1738	}
1481		1739
1482	sub key_down {	1740	sub key_down {
1483	my ($self, $ev) = @_;	1741	my ($self, $ev) = @_;
1484		1742
…		…
1486	my $sym = $ev->{sym};	1744	my $sym = $ev->{sym};
1487	my $uni = $ev->{unicode};	1745	my $uni = $ev->{unicode};
1488		1746
1489	my $text = $self->get_text;	1747	my $text = $self->get_text;
1490		1748
1491	if ($sym == 8) {	1749	if ($uni == 8) {
1492	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};	1750	substr $text, --$self->{cursor}, 1, "" if $self->{cursor};
1493	} elsif ($sym == 127) {	1751	} elsif ($uni == 127) {
1494	substr $text, $self->{cursor}, 1, "";	1752	substr $text, $self->{cursor}, 1, "";
1495	} elsif ($sym == CFClient::SDLK_LEFT) {	1753	} elsif ($sym == CFClient::SDLK_LEFT) {
1496	--$self->{cursor} if $self->{cursor};	1754	--$self->{cursor} if $self->{cursor};
1497	} elsif ($sym == CFClient::SDLK_RIGHT) {	1755	} elsif ($sym == CFClient::SDLK_RIGHT) {
1498	++$self->{cursor} if $self->{cursor} < length $self->{text};	1756	++$self->{cursor} if $self->{cursor} < length $self->{text};
1499	} elsif ($sym == CFClient::SDLK_HOME) {	1757	} elsif ($sym == CFClient::SDLK_HOME) {
1500	$self->{cursor} = 0;	1758	$self->{cursor} = 0;
1501	} elsif ($sym == CFClient::SDLK_END) {	1759	} elsif ($sym == CFClient::SDLK_END) {
1502	$self->{cursor} = length $text;	1760	$self->{cursor} = length $text;
1503	} elsif ($sym == 27) {	1761	} elsif ($uni == 27) {
1504	$self->emit ('escape');	1762	$self->_emit ('escape');
1505	} elsif ($uni) {	1763	} elsif ($uni) {
1506	substr $text, $self->{cursor}++, 0, chr $uni;	1764	substr $text, $self->{cursor}++, 0, chr $uni;
		1765	} else {
		1766	return 0;
1507	}	1767	}
1508		1768
1509	$self->_set_text ($text);	1769	$self->_set_text ($text);
1510	$self->update;	1770
		1771	$self->realloc;
		1772
		1773	1
1511	}	1774	}
1512		1775
1513	sub focus_in {	1776	sub focus_in {
1514	my ($self) = @_;	1777	my ($self) = @_;
1515		1778
…		…
1530	utf8::encode $text;	1793	utf8::encode $text;
1531	$self->{cursor} = length substr $text, 0, $idx;	1794	$self->{cursor} = length substr $text, 0, $idx;
1532		1795
1533	$self->_set_text ($self->{text});	1796	$self->_set_text ($self->{text});
1534	$self->update;	1797	$self->update;
		1798
		1799	1
1535	}	1800	}
1536		1801
1537	sub mouse_motion {	1802	sub mouse_motion {
1538	my ($self, $ev, $x, $y) = @_;	1803	my ($self, $ev, $x, $y) = @_;
1539	# printf "M %d,%d %d,%d\n", $ev->motion_x, $ev->motion_y, $x, $y;#d#	1804	# printf "M %d,%d %d,%d\n", $ev->motion_x, $ev->motion_y, $x, $y;#d#
		1805
		1806	0
1540	}	1807	}
1541		1808
1542	sub _draw {	1809	sub _draw {
1543	my ($self) = @_;	1810	my ($self) = @_;
1544		1811
1545	local $self->{fg} = $self->{fg};	1812	local $self->{fg} = $self->{fg};
1546		1813
1547	if ($FOCUS == $self) {	1814	if ($FOCUS == $self) {
1548	glColor @{$self->{active_bg}};	1815	glColor_premultiply @{$self->{active_bg}};
1549	$self->{fg} = $self->{active_fg};	1816	$self->{fg} = $self->{active_fg};
1550	} else {	1817	} else {
1551	glColor @{$self->{bg}};	1818	glColor_premultiply @{$self->{bg}};
1552	}	1819	}
1553		1820
1554	glEnable GL_BLEND;	1821	glEnable GL_BLEND;
1555	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	1822	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1556	glBegin GL_QUADS;	1823	glBegin GL_QUADS;
1557	glVertex 0 , 0;	1824	glVertex 0 , 0;
1558	glVertex 0 , $self->{h};	1825	glVertex 0 , $self->{h};
1559	glVertex $self->{w}, $self->{h};	1826	glVertex $self->{w}, $self->{h};
1560	glVertex $self->{w}, 0;	1827	glVertex $self->{w}, 0;
…		…
1595	if ($sym == 13) {	1862	if ($sym == 13) {
1596	unshift @{$self->{history}},	1863	unshift @{$self->{history}},
1597	my $txt = $self->get_text;	1864	my $txt = $self->get_text;
1598	$self->{history_pointer} = -1;	1865	$self->{history_pointer} = -1;
1599	$self->{history_saveback} = '';	1866	$self->{history_saveback} = '';
1600	$self->emit (activate => $txt);	1867	$self->_emit (activate => $txt);
1601	$self->update;	1868	$self->update;
1602		1869
1603	} elsif ($sym == CFClient::SDLK_UP) {	1870	} elsif ($sym == CFClient::SDLK_UP) {
1604	if ($self->{history_pointer} < 0) {	1871	if ($self->{history_pointer} < 0) {
1605	$self->{history_saveback} = $self->get_text;	1872	$self->{history_saveback} = $self->get_text;
…		…
1621	} else {	1888	} else {
1622	$self->set_text ($self->{history_saveback});	1889	$self->set_text ($self->{history_saveback});
1623	}	1890	}
1624		1891
1625	} else {	1892	} else {
1626	$self->SUPER::key_down ($ev);	1893	return $self->SUPER::key_down ($ev)
		1894	}
		1895
1627	}	1896	1
1628
1629	}	1897	}
1630		1898
1631	#############################################################################	1899	#############################################################################
1632		1900
1633	package CFClient::UI::Button;	1901	package CFClient::UI::Button;
…		…
1642		1910
1643	sub new {	1911	sub new {
1644	my $class = shift;	1912	my $class = shift;
1645		1913
1646	$class->SUPER::new (	1914	$class->SUPER::new (
1647	padding => 4,	1915	padding_x => 4,
		1916	padding_y => 4,
1648	fg => [1, 1, 1],	1917	fg => [1, 1, 1],
1649	bg => [1, 1, 1, 0.2],
1650	active_fg => [0, 0, 1],	1918	active_fg => [0, 0, 1],
1651	can_hover => 1,	1919	can_hover => 1,
1652	align => 0,	1920	align => 0,
1653	valign => 0,	1921	valign => 0,
1654	can_events => 1,	1922	can_events => 1,
1655	@_	1923	@_
1656	)	1924	)
1657	}	1925	}
1658		1926
		1927	sub activate { }
		1928
1659	sub button_up {	1929	sub button_up {
1660	my ($self, $ev, $x, $y) = @_;	1930	my ($self, $ev, $x, $y) = @_;
1661		1931
		1932	$self->emit ("activate")
1662	if ($x >= 0 && $x < $self->{w}	1933	if $x >= 0 && $x < $self->{w}
1663	&& $y >= 0 && $y < $self->{h}) {	1934	&& $y >= 0 && $y < $self->{h};
1664	$self->emit ("activate");	1935
1665	}	1936	1
1666	}	1937	}
1667		1938
1668	sub _draw {	1939	sub _draw {
1669	my ($self) = @_;	1940	my ($self) = @_;
1670		1941
1671	local $self->{fg} = $self->{fg};	1942	local $self->{fg} = $GRAB == $self ? $self->{active_fg} : $self->{fg};
1672
1673	if ($GRAB == $self) {
1674	$self->{fg} = $self->{active_fg};
1675	}
1676		1943
1677	glEnable GL_TEXTURE_2D;	1944	glEnable GL_TEXTURE_2D;
1678	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	1945	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1679	glColor 0, 0, 0, 1;	1946	glColor 0, 0, 0, 1;
1680		1947
…		…
1699		1966
1700	sub new {	1967	sub new {
1701	my $class = shift;	1968	my $class = shift;
1702		1969
1703	$class->SUPER::new (	1970	$class->SUPER::new (
1704	padding => 2,	1971	padding_x => 2,
		1972	padding_y => 2,
1705	fg => [1, 1, 1],	1973	fg => [1, 1, 1],
1706	active_fg => [1, 1, 0],	1974	active_fg => [1, 1, 0],
		1975	bg => [0, 0, 0, 0.2],
		1976	active_bg => [1, 1, 1, 0.5],
1707	state => 0,	1977	state => 0,
1708	can_hover => 1,	1978	can_hover => 1,
1709	@_	1979	@_
1710	)	1980	)
1711	}	1981	}
1712		1982
1713	sub size_request {	1983	sub size_request {
1714	my ($self) = @_;	1984	my ($self) = @_;
1715		1985
1716	($self->{padding} * 2 + 6) x 2	1986	(6) x 2
1717	}	1987	}
1718		1988
1719	sub button_down {	1989	sub button_down {
1720	my ($self, $ev, $x, $y) = @_;	1990	my ($self, $ev, $x, $y) = @_;
1721		1991
1722	if ($x >= $self->{padding} && $x < $self->{w} - $self->{padding}	1992	if ($x >= $self->{padding_x} && $x < $self->{w} - $self->{padding_x}
1723	&& $y >= $self->{padding} && $y < $self->{h} - $self->{padding}) {	1993	&& $y >= $self->{padding_y} && $y < $self->{h} - $self->{padding_y}) {
1724	$self->{state} = !$self->{state};	1994	$self->{state} = !$self->{state};
1725	$self->emit (changed => $self->{state});	1995	$self->_emit (changed => $self->{state});
		1996	} else {
		1997	return 0
		1998	}
		1999
1726	}	2000	1
1727	}	2001	}
1728		2002
1729	sub _draw {	2003	sub _draw {
1730	my ($self) = @_;	2004	my ($self) = @_;
1731		2005
1732	$self->SUPER::_draw;	2006	$self->SUPER::_draw;
1733		2007
1734	glTranslate $self->{padding} + 0.375, $self->{padding} + 0.375, 0;	2008	glTranslate $self->{padding_x} + 0.375, $self->{padding_y} + 0.375, 0;
1735		2009
1736	my $s = (List::Util::min @$self{qw(w h)}) - $self->{padding} * 2;	2010	my ($w, $h) = @$self{qw(w h)};
		2011
		2012	my $s = List::Util::min $w - $self->{padding_x} * 2, $h - $self->{padding_y} * 2;
1737		2013
1738	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };	2014	glColor @{ $FOCUS == $self ? $self->{active_fg} : $self->{fg} };
1739		2015
		2016	my $tex = $self->{state} ? $tex[1] : $tex[0];
		2017
1740	glEnable GL_TEXTURE_2D;	2018	glEnable GL_TEXTURE_2D;
1741
1742	my $tex = $self->{state} ? $tex[1] : $tex[0];
1743
1744	$tex->draw_quad_alpha (0, 0, $s, $s);	2019	$tex->draw_quad_alpha (0, 0, $s, $s);
1745
1746	glDisable GL_TEXTURE_2D;	2020	glDisable GL_TEXTURE_2D;
1747	}	2021	}
1748		2022
1749	#############################################################################	2023	#############################################################################
1750		2024
…		…
1898		2172
1899	my $h1 = $self->{h} * (1 - $ycut1);	2173	my $h1 = $self->{h} * (1 - $ycut1);
1900	my $h2 = $self->{h} * (1 - $ycut2);	2174	my $h2 = $self->{h} * (1 - $ycut2);
1901		2175
1902	glEnable GL_BLEND;	2176	glEnable GL_BLEND;
1903	glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;	2177	glBlendFuncSeparate GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA,
		2178	GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
1904	glEnable GL_TEXTURE_2D;	2179	glEnable GL_TEXTURE_2D;
1905	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2180	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
1906		2181
1907	glBindTexture GL_TEXTURE_2D, $t1->{name};	2182	glBindTexture GL_TEXTURE_2D, $t1->{name};
1908	glBegin GL_QUADS;	2183	glBegin GL_QUADS;
…		…
1997	qw(s1_slider.png s1_slider_bg.png);	2272	qw(s1_slider.png s1_slider_bg.png);
1998		2273
1999	sub new {	2274	sub new {
2000	my $class = shift;	2275	my $class = shift;
2001		2276
2002	# range [value, low, high, page]	2277	# range [value, low, high, page, unit]
2003		2278
2004	# TODO: 0-width page	2279	# TODO: 0-width page
2005	# TODO: req_w/h are wrong with vertical	2280	# TODO: req_w/h are wrong with vertical
2006	# TODO: calculations are off	2281	# TODO: calculations are off
2007	my $self = $class->SUPER::new (	2282	my $self = $class->SUPER::new (
2008	fg => [1, 1, 1],	2283	fg => [1, 1, 1],
2009	active_fg => [0, 0, 0],	2284	active_fg => [0, 0, 0],
		2285	bg => [0, 0, 0, 0.2],
		2286	active_bg => [1, 1, 1, 0.5],
2010	range => [0, 0, 100, 10],	2287	range => [0, 0, 100, 10, 0],
2011	req_w => $::WIDTH / 80,	2288	min_w => $::WIDTH / 80,
2012	req_h => $::WIDTH / 80,	2289	min_h => $::WIDTH / 80,
2013	vertical => 0,	2290	vertical => 0,
2014	can_hover => 1,	2291	can_hover => 1,
2015	inner_pad => 5,	2292	inner_pad => 0.02,
2016	@_	2293	@_
2017	);	2294	);
2018		2295
		2296	$self->set_value ($self->{range}[0]);
		2297	$self->update;
		2298
2019	$self	2299	$self
2020	}	2300	}
2021		2301
		2302	sub changed { }
		2303
		2304	sub set_range {
		2305	my ($self, $range) = @_;
		2306
		2307	($range, $self->{range}) = ($self->{range}, $range);
		2308
		2309	$self->update
		2310	if "@$range" ne "@{$self->{range}}";
		2311	}
		2312
		2313	sub set_value {
		2314	my ($self, $value) = @_;
		2315
		2316	my ($old_value, $lo, $hi, $page, $unit) = @{$self->{range}};
		2317
		2318	$hi = $lo + 1 if $hi <= $lo;
		2319
		2320	$page = $hi - $lo if $page > $hi - $lo;
		2321
		2322	$value = $lo if $value < $lo;
		2323	$value = $hi - $page if $value > $hi - $page;
		2324
		2325	$value = $lo + $unit * int +($value - $lo + $unit * 0.5) / $unit
		2326	if $unit;
		2327
		2328	@{$self->{range}} = ($value, $lo, $hi, $page, $unit);
		2329
		2330	if ($value != $old_value) {
		2331	$self->_emit (changed => $value);
		2332	$self->update;
		2333	}
		2334	}
		2335
2022	sub size_request {	2336	sub size_request {
2023	my ($self) = @_;	2337	my ($self) = @_;
2024		2338
2025	my $w = $self->{req_w};	2339	($self->{req_w}, $self->{req_h})
2026	my $h = $self->{req_h};
2027
2028	$self->{vertical} ? ($h, $w) : ($w, $h)
2029	}	2340	}
2030		2341
2031	sub button_down {	2342	sub button_down {
2032	my ($self, $ev, $x, $y) = @_;	2343	my ($self, $ev, $x, $y) = @_;
2033		2344
2034	$self->SUPER::button_down ($ev, $x, $y);	2345	$self->SUPER::button_down ($ev, $x, $y);
		2346
		2347	$self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x];
		2348
2035	$self->mouse_motion ($ev, $x, $y);	2349	$self->mouse_motion ($ev, $x, $y)
2036	}	2350	}
2037		2351
2038	sub mouse_motion {	2352	sub mouse_motion {
2039	my ($self, $ev, $x, $y) = @_;	2353	my ($self, $ev, $x, $y) = @_;
2040		2354
2041	if ($GRAB == $self) {	2355	if ($GRAB == $self) {
		2356	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});
		2357
		2358	my (undef, $lo, $hi, $page) = @{$self->{range}};
		2359
		2360	$x = ($x - $self->{click}[1]) / ($w * $self->{scale});
		2361
		2362	$self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo));
		2363	} else {
		2364	return 0;
		2365	}
		2366
		2367	1
		2368	}
		2369
		2370	sub update {
		2371	my ($self) = @_;
		2372
		2373	delete $self->{knob_w};
		2374	$self->SUPER::update;
		2375	}
		2376
		2377	sub _draw {
		2378	my ($self) = @_;
		2379
		2380	unless ($self->{knob_w}) {
		2381	$self->set_value ($self->{range}[0]);
		2382
2042	my ($value, $lo, $hi, $page) = @{$self->{range}};	2383	my ($value, $lo, $hi, $page) = @{$self->{range}};
		2384	my $range = ($hi - $page - $lo) || 1e-100;
2043		2385
2044	my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w});	2386	my $knob_w = List::Util::min 1, $page / ($hi - $lo) || 0.1;
2045		2387
2046	my $inner_pad_px = $self->_calc_inner_pad_px ($w);	2388	$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	2389	$self->{scale} = 1 - 2 * $self->{offset} || 1e-100;
2048		2390
2049	$x -= $inner_pad_px; # substract the padding	2391	$value = ($value - $lo) / $range;
2050	$x = $x * ($hi - $lo) / $inner_w + $lo;	2392	$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		2393
2055	$self->emit (changed => $x);	2394	$self->{knob_x} = $value - $knob_w * 0.5;
2056	$self->update;	2395	$self->{knob_w} = $knob_w;
2057	}	2396	}
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		2397
2071	$self->SUPER::_draw ();	2398	$self->SUPER::_draw ();
2072		2399
2073	my ($w, $h) = @$self{qw(w h)};	2400	glScale $self->{w}, $self->{h};
2074		2401
2075	if ($self->{vertical}) {	2402	if ($self->{vertical}) {
2076	# draw a vertical slider like a rotated horizontal slider	2403	# draw a vertical slider like a rotated horizontal slider
2077		2404
		2405	glTranslate 1, 0, 0;
2078	glRotate 90, 0, 0, 1;	2406	glRotate 90, 0, 0, 1;
2079	glTranslate 0, -$self->{w}, 0;
2080
2081	($w, $h) = ($h, $w);
2082	}	2407	}
2083		2408
2084	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};	2409	my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg};
2085	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};	2410	my $bg = $FOCUS == $self ? $self->{active_bg} : $self->{bg};
2086		2411
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;	2412	glEnable GL_TEXTURE_2D;
2106	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2413	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2107		2414
2108	# draw background	2415	# draw background
2109	$tex[1]->draw_quad_alpha (0, 0, $w, $h);	2416	$tex[1]->draw_quad_alpha (0, 0, 1, 1);
2110		2417
2111	# draw handle	2418	# draw handle
2112	$tex[0]->draw_quad_alpha ($knob_a, 0, $knob_b - $knob_a, $h);	2419	$tex[0]->draw_quad_alpha ($self->{knob_x}, 0, $self->{knob_w}, 1);
2113		2420
2114	glDisable GL_TEXTURE_2D;	2421	glDisable GL_TEXTURE_2D;
2115	}	2422	}
		2423
		2424	#############################################################################
		2425
		2426	package CFClient::UI::ValSlider;
		2427
		2428	our @ISA = CFClient::UI::HBox::;
		2429
		2430	sub new {
		2431	my ($class, %arg) = @_;
		2432
		2433	my $range = delete $arg{range};
		2434
		2435	my $self = $class->SUPER::new (
		2436	slider => (new CFClient::UI::Slider expand => 1, range => $range),
		2437	entry => (new CFClient::UI::Label text => "", template => delete $arg{template}),
		2438	to_value => sub { shift },
		2439	from_value => sub { shift },
		2440	%arg,
		2441	);
		2442
		2443	$self->{slider}->connect (changed => sub {
		2444	my ($self, $value) = @_;
		2445	$self->{parent}{entry}->set_text ($self->{parent}{to_value}->($value));
		2446	$self->{parent}->emit (changed => $value);
		2447	});
		2448
		2449	# $self->{entry}->connect (changed => sub {
		2450	# my ($self, $value) = @_;
		2451	# $self->{parent}{slider}->set_value ($self->{parent}{from_value}->($value));
		2452	# $self->{parent}->emit (changed => $value);
		2453	# });
		2454
		2455	$self->add ($self->{slider}, $self->{entry});
		2456
		2457	$self->{slider}->emit (changed => $self->{slider}{range}[0]);
		2458
		2459	$self
		2460	}
		2461
		2462	sub set_range { shift->{slider}->set_range (@_) }
		2463	sub set_value { shift->{slider}->set_value (@_) }
2116		2464
2117	#############################################################################	2465	#############################################################################
2118		2466
2119	package CFClient::UI::TextView;	2467	package CFClient::UI::TextView;
2120		2468
…		…
2150		2498
2151	$self->{fontsize} = $fontsize;	2499	$self->{fontsize} = $fontsize;
2152	$self->reflow;	2500	$self->reflow;
2153	}	2501	}
2154		2502
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 {	2503	sub size_allocate {
2175	my ($self, $w, $h) = @_;	2504	my ($self, $w, $h) = @_;
2176		2505
2177	$self->SUPER::size_allocate ($w, $h);	2506	$self->SUPER::size_allocate ($w, $h);
2178		2507
…		…
2181	$self->{layout}->set_width ($self->{children}[0]{w});	2510	$self->{layout}->set_width ($self->{children}[0]{w});
2182		2511
2183	$self->reflow;	2512	$self->reflow;
2184	}	2513	}
2185		2514
		2515	sub text_size {
		2516	my ($self, $text, $indent) = @_;
		2517
		2518	my $layout = $self->{layout};
		2519
		2520	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2521	$layout->set_width ($self->{children}[0]{w} - $indent);
		2522	$layout->set_markup ($text);
		2523
		2524	$layout->size
		2525	}
		2526
		2527	sub reflow {
		2528	my ($self) = @_;
		2529
		2530	$self->{need_reflow}++;
		2531	$self->update;
		2532	}
		2533
		2534	sub set_offset {
		2535	my ($self, $offset) = @_;
		2536
		2537	# todo: base offset on lines or so, not on pixels
		2538	$self->{children}[1]->set_value ($offset);
		2539	}
		2540
		2541	sub clear {
		2542	my ($self) = @_;
		2543
		2544	$self->{par} = [];
		2545	$self->{height} = 0;
		2546	$self->{children}[1]->set_range ([0, 0, 0, 1, 1]);
		2547	}
		2548
2186	sub add_paragraph {	2549	sub add_paragraph {
2187	my ($self, $color, $text) = @_;	2550	my ($self, $color, $text, $indent) = @_;
2188		2551
2189	#TODO: intelligently "reformat" paragraph	2552	for my $line (split /\n/, $text) {
2190		2553	my ($w, $h) = $self->text_size ($line);
2191	my $height = $self->text_height ($text);
2192
2193	$self->{height} += $height;	2554	$self->{height} += $h;
		2555	push @{$self->{par}}, [$w + $indent, $h, $color, $indent, $line];
		2556	}
2194		2557
2195	push @{$self->{par}}, [$height, $color, $text];
2196
2197	$self->{children}[1]{range} = [$self->{height} - $self->{h}, 0, $self->{height}, $self->{h}];	2558	$self->{children}[1]->set_range ([$self->{height}, 0, $self->{height}, $self->{h}, 1]);
2198	$self->{children}[1]->update;
2199	}	2559	}
2200		2560
2201	sub update {	2561	sub update {
2202	my ($self) = @_;	2562	my ($self) = @_;
2203		2563
…		…
2205		2565
2206	return unless $self->{h} > 0;	2566	return unless $self->{h} > 0;
2207		2567
2208	delete $self->{texture};	2568	delete $self->{texture};
2209		2569
2210	$ROOT->on_refresh ($self, sub {	2570	$ROOT->on_post_alloc ($self, sub {
		2571	my ($W, $H) = @{$self->{children}[0]}{qw(w h)};
		2572
2211	if (delete $self->{need_reflow}) {	2573	if (delete $self->{need_reflow}) {
2212	my $height = 0;	2574	my $height = 0;
2213		2575
2214	$height += $_->[0] = $self->text_height ($_->[2])	2576	my $layout = $self->{layout};
		2577
		2578	$layout->set_height ($self->{fontsize} * $::FONTSIZE);
		2579
2215	for @{$self->{par}};	2580	for (@{$self->{par}}) {
		2581	if (1 || $_->[0] >= $W) { # TODO: works,but needs reconfigure etc. support
		2582	$layout->set_width ($W - $_->[3]);
		2583	$layout->set_markup ($_->[4]);
		2584	my ($w, $h) = $layout->size;
		2585	$_->[0] = $w + $_->[3];
		2586	$_->[1] = $h;
		2587	}
		2588
		2589	$height += $_->[1];
		2590	}
2216		2591
2217	$self->{height} = $height;	2592	$self->{height} = $height;
2218		2593
2219	$self->{children}[1]{range} = [$height - $self->{h}, 0, $height, $self->{h}];	2594	$self->{children}[1]->set_range ([$height, 0, $height, $H, 1]);
2220		2595
2221	delete $self->{texture};	2596	delete $self->{texture};
2222	}	2597	}
2223		2598
2224	$self->{texture} ||= new_from_opengl CFClient::Texture $self->{children}[0]{w}, $self->{children}[0]{h}, sub {	2599	$self->{texture} ||= new_from_opengl CFClient::Texture $W, $H, sub {
2225	glClearColor 0, 0, 0, 0;	2600	glClearColor 0, 0, 0, 0;
2226	glClear GL_COLOR_BUFFER_BIT;	2601	glClear GL_COLOR_BUFFER_BIT;
2227		2602
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];	2603	my $top = int $self->{children}[1]{range}[0];
2232		2604
2233	my $y0 = $top;	2605	my $y0 = $top;
2234	my $y1 = $top + $self->{h};	2606	my $y1 = $top + $H;
2235		2607
2236	my $y = 0;	2608	my $y = 0;
2237		2609
2238	my $layout = $self->{layout};	2610	my $layout = $self->{layout};
2239		2611
2240	$layout->set_font ($self->{font}) if $self->{font};	2612	$layout->set_font ($self->{font}) if $self->{font};
2241		2613
		2614	glEnable GL_BLEND;
		2615	#TODO# not correct in windows where rgba is forced off
		2616	glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA;
		2617
2242	for my $par (@{$self->{par}}) {	2618	for my $par (@{$self->{par}}) {
2243	my $h = $par->[0];	2619	my $h = $par->[1];
2244		2620
2245	if ($y0 < $y + $h && $y < $y1) {	2621	if ($y0 < $y + $h && $y < $y1) {
2246	$layout->set_foreground (@{ $par->[1] });	2622	$layout->set_foreground (@{ $par->[2] });
		2623	$layout->set_width ($W - $par->[3]);
2247	$layout->set_markup ($par->[2]);	2624	$layout->set_markup ($par->[4]);
2248		2625
2249	my ($W, $H) = $layout->size;	2626	my ($w, $h, $data, $format, $internalformat) = $layout->render;
2250	CFClient::Texture->new_from_layout ($layout)->draw_quad_alpha_premultiplied (0, $y - $y0);	2627
		2628	glRasterPos $par->[3], $y - $y0;
		2629	glDrawPixels $w, $h, $format, GL_UNSIGNED_BYTE, $data;
2251	}	2630	}
2252		2631
2253	$y += $h;	2632	$y += $h;
2254	}	2633	}
2255		2634
2256	glDisable GL_TEXTURE_2D;	2635	glDisable GL_BLEND;
2257	};	2636	};
2258	});	2637	});
2259	}	2638	}
2260		2639
2261	sub _draw {	2640	sub _draw {
2262	my ($self) = @_;	2641	my ($self) = @_;
2263		2642
2264	glEnable GL_TEXTURE_2D;	2643	glEnable GL_TEXTURE_2D;
2265	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2644	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2266	glColor 1, 1, 1, 1;	2645	glColor 0, 0, 0, 1;
2267	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});	2646	$self->{texture}->draw_quad_alpha_premultiplied (0, 0, $self->{children}[0]{w}, $self->{children}[0]{h});
2268	glDisable GL_TEXTURE_2D;	2647	glDisable GL_TEXTURE_2D;
2269		2648
2270	$self->{children}[1]->draw;	2649	$self->{children}[1]->draw;
2271		2650
…		…
2321		2700
2322	sub new {	2701	sub new {
2323	my $class = shift;	2702	my $class = shift;
2324		2703
2325	my $self = $class->SUPER::new (	2704	my $self = $class->SUPER::new (
2326	state => 0,	2705	state => 0,
2327	connect_activate => \&toggle_flopper,	2706	on_activate => \&toggle_flopper,
2328	@_	2707	@_
2329	);	2708	);
2330		2709
2331	if ($self->{state}) {
2332	$self->{state} = 0;
2333	$self->toggle_flopper;
2334	}
2335
2336	$self	2710	$self
2337	}	2711	}
2338		2712
2339	sub toggle_flopper {	2713	sub toggle_flopper {
2340	my ($self) = @_;	2714	my ($self) = @_;
2341		2715
2342	# TODO: use animation	2716	$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	}	2717	}
2354		2718
2355	#############################################################################	2719	#############################################################################
2356		2720
2357	package CFClient::UI::Tooltip;	2721	package CFClient::UI::Tooltip;
…		…
2367	@_,	2731	@_,
2368	can_events => 0,	2732	can_events => 0,
2369	)	2733	)
2370	}	2734	}
2371		2735
2372	sub set_markup {	2736	sub set_tooltip_from {
2373	my ($self, $text, $font) = @_;	2737	my ($self, $widget) = @_;
2374		2738
		2739	my $tooltip = $widget->{tooltip};
		2740
		2741	if ($ENV{CFPLUS_DEBUG} & 2) {
		2742	$tooltip .= "\n\n" . (ref $widget) . "\n"
		2743	. "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n"
		2744	. "req $widget->{req_w} $widget->{req_h}\n"
		2745	. "visible $widget->{visible}";
		2746	}
		2747
2375	$self->{label} = new CFClient::UI::Label	2748	$self->add (new CFClient::UI::Label
		2749	markup => $tooltip,
		2750	max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH,
2376	fontsize => 0.8,	2751	fontsize => 0.8,
2377	fg => [0, 0, 0],	2752	fg => [0, 0, 0, 1],
		2753	ellipsise => 0,
2378	font => ($font || $::FONT_PROP);	2754	font => ($widget->{tooltip_font} || $::FONT_PROP),
2379		2755	);
2380	$self->{label}->set_max_size ($::WIDTH * 0.3);
2381	$self->{label}->set_markup ($text);
2382	$self->add ($self->{label});
2383	}	2756	}
2384		2757
2385	sub size_request {	2758	sub size_request {
2386	my ($self) = @_;	2759	my ($self) = @_;
2387		2760
…		…
2394	my ($self, $w, $h) = @_;	2767	my ($self, $w, $h) = @_;
2395		2768
2396	$self->SUPER::size_allocate ($w - 4, $h - 4);	2769	$self->SUPER::size_allocate ($w - 4, $h - 4);
2397	}	2770	}
2398		2771
		2772	sub visibility_change {
		2773	my ($self, $visible) = @_;
		2774
		2775	return unless $visible;
		2776
		2777	$self->{root}->on_post_alloc ("move_$self" => sub {
		2778	my $widget = $self->{owner}
		2779	or return;
		2780
		2781	my ($x, $y) = $widget->coord2global ($widget->{w}, 0);
		2782
		2783	($x, $y) = $widget->coord2global (-$self->{w}, 0)
		2784	if $x + $self->{w} > $::WIDTH;
		2785
		2786	$self->move_abs ($x, $y);
		2787	});
		2788	}
		2789
2399	sub _draw {	2790	sub _draw {
2400	my ($self) = @_;	2791	my ($self) = @_;
2401		2792
2402	glPushMatrix;
2403	glTranslate 0.375, 0.375;	2793	glTranslate 0.375, 0.375;
2404		2794
2405	my ($w, $h) = @$self{qw(w h)};	2795	my ($w, $h) = @$self{qw(w h)};
2406		2796
2407	glColor 1, 0.8, 0.4;	2797	glColor 1, 0.8, 0.4;
…		…
2418	glVertex 0 , $h;	2808	glVertex 0 , $h;
2419	glVertex $w, $h;	2809	glVertex $w, $h;
2420	glVertex $w, 0;	2810	glVertex $w, 0;
2421	glEnd;	2811	glEnd;
2422		2812
2423	glPopMatrix;	2813	glTranslate 2 - 0.375, 2 - 0.375;
2424		2814
2425	glTranslate 2, 2;
2426	$self->SUPER::_draw;	2815	$self->SUPER::_draw;
2427	}	2816	}
2428		2817
2429	#############################################################################	2818	#############################################################################
2430		2819
…		…
2435	use CFClient::OpenGL;	2824	use CFClient::OpenGL;
2436		2825
2437	sub new {	2826	sub new {
2438	my $class = shift;	2827	my $class = shift;
2439		2828
2440	$class->SUPER::new (	2829	my $self = $class->SUPER::new (
2441	aspect => 1,	2830	aspect => 1,
		2831	can_events => 0,
2442	@_,	2832	@_,
2443	)	2833	);
		2834
		2835	if ($self->{anim} && $self->{animspeed}) {
		2836	Scalar::Util::weaken (my $widget = $self);
		2837
		2838	$self->{timer} = Event->timer (
		2839	at => $self->{animspeed} * int $::NOW / $self->{animspeed},
		2840	hard => 1,
		2841	interval => $self->{animspeed},
		2842	cb => sub {
		2843	++$widget->{frame};
		2844	$widget->update;
		2845	},
		2846	);
		2847	}
		2848
		2849	$self
2444	}	2850	}
2445		2851
2446	sub size_request {	2852	sub size_request {
2447	(32, 8)	2853	(32, 8)
2448	}	2854	}
2449		2855
		2856	sub update {
		2857	my ($self) = @_;
		2858
		2859	return unless $self->{visible};
		2860
		2861	$self->SUPER::update;
		2862	}
		2863
2450	sub _draw {	2864	sub _draw {
2451	my ($self) = @_;	2865	my ($self) = @_;
2452		2866
2453	return unless $::CONN;#d# manage and cache textures differently	2867	return unless $::CONN;
		2868
		2869	my $face;
		2870
		2871	if ($self->{frame}) {
		2872	my $anim = $::CONN->{anim}[$self->{anim}];
		2873
		2874	$face = $anim->[ $self->{frame} % @$anim ]
		2875	if $anim && @$anim;
		2876	}
		2877
2454	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$self->{face}]];	2878	my $tex = $::CONN->{texture}[$::CONN->{faceid}[$face || $self->{face}]];
2455		2879
2456	# TODO animation
2457	if ($tex) {	2880	if ($tex) {
2458	glEnable GL_TEXTURE_2D;	2881	glEnable GL_TEXTURE_2D;
2459	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;	2882	glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;
2460	glColor 1, 1, 1, 1;	2883	glColor 0, 0, 0, 1;
2461	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});	2884	$tex->draw_quad_alpha (0, 0, $self->{w}, $self->{h});
2462	glDisable GL_TEXTURE_2D;	2885	glDisable GL_TEXTURE_2D;
2463	}	2886	}
2464	}	2887	}
2465		2888
		2889	sub DESTROY {
		2890	my ($self) = @_;
		2891
		2892	$self->{timer}->cancel
		2893	if $self->{timer};
		2894
		2895	$self->SUPER::DESTROY;
		2896	}
		2897
2466	#############################################################################	2898	#############################################################################
2467		2899
2468	package CFClient::UI::InventoryItem;	2900	package CFClient::UI::Buttonbar;
2469		2901
2470	our @ISA = CFClient::UI::HBox::;	2902	our @ISA = CFClient::UI::HBox::;
2471		2903
2472	sub new {	2904	# 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		2905
2575	#############################################################################	2906	#############################################################################
2576		2907
2577	package CFClient::UI::Menu;	2908	package CFClient::UI::Menu;
2578		2909
…		…
2590	);	2921	);
2591		2922
2592	$self->add ($self->{vbox} = new CFClient::UI::VBox);	2923	$self->add ($self->{vbox} = new CFClient::UI::VBox);
2593		2924
2594	for my $item (@{ $self->{items} }) {	2925	for my $item (@{ $self->{items} }) {
2595	my ($widget, $cb) = @$item;	2926	my ($widget, $cb, $tooltip) = @$item;
2596		2927
2597	# handle various types of items, only text for now	2928	# handle various types of items, only text for now
2598	if (!ref $widget) {	2929	if (!ref $widget) {
2599	$widget = new CFClient::UI::Label	2930	$widget = new CFClient::UI::Label
2600	can_hover => 1,	2931	can_hover => 1,
2601	can_events => 1,	2932	can_events => 1,
2602	text => $widget;	2933	text => $widget,
		2934	tooltip => $tooltip
2603	}	2935	}
2604		2936
2605	$self->{item}{$widget} = $item;	2937	$self->{item}{$widget} = $item;
2606		2938
2607	$self->{vbox}->add ($widget);	2939	$self->{vbox}->add ($widget);
…		…
2612		2944
2613	# popup given the event (must be a mouse button down event currently)	2945	# popup given the event (must be a mouse button down event currently)
2614	sub popup {	2946	sub popup {
2615	my ($self, $ev) = @_;	2947	my ($self, $ev) = @_;
2616		2948
2617	$self->emit ("popdown");	2949	$self->_emit ("popdown");
2618		2950
2619	# maybe save $GRAB? must be careful about events...	2951	# maybe save $GRAB? must be careful about events...
2620	$GRAB = $self;	2952	$GRAB = $self;
2621	$self->{button} = $ev->{button};	2953	$self->{button} = $ev->{button};
2622		2954
2623	$self->show;	2955	$self->show;
2624	$self->move ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);	2956	$self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5);
2625	}	2957	}
2626		2958
2627	sub mouse_motion {	2959	sub mouse_motion {
2628	my ($self, $ev, $x, $y) = @_;	2960	my ($self, $ev, $x, $y) = @_;
2629		2961
2630	# TODO: should use vbox->find_widget or so	2962	# TODO: should use vbox->find_widget or so
2631	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});	2963	$HOVER = $ROOT->find_widget ($ev->{x}, $ev->{y});
2632	$self->{hover} = $self->{item}{$HOVER};	2964	$self->{hover} = $self->{item}{$HOVER};
		2965
		2966	0
2633	}	2967	}
2634		2968
2635	sub button_up {	2969	sub button_up {
2636	my ($self, $ev, $x, $y) = @_;	2970	my ($self, $ev, $x, $y) = @_;
2637		2971
2638	if ($ev->{button} == $self->{button}) {	2972	if ($ev->{button} == $self->{button}) {
2639	undef $GRAB;	2973	undef $GRAB;
2640	$self->hide;	2974	$self->hide;
2641		2975
2642	$self->emit ("popdown");	2976	$self->_emit ("popdown");
2643	$self->{hover}[1]->() if $self->{hover};	2977	$self->{hover}[1]->() if $self->{hover};
		2978	} else {
		2979	return 0
		2980	}
		2981
2644	}	2982	1
2645	}	2983	}
2646		2984
2647	#############################################################################	2985	#############################################################################
2648		2986
		2987	package CFClient::UI::Multiplexer;
		2988
		2989	our @ISA = CFClient::UI::Container::;
		2990
		2991	sub new {
		2992	my $class = shift;
		2993
		2994	my $self = $class->SUPER::new (
		2995	@_,
		2996	);
		2997
		2998	$self->{current} = $self->{children}[0]
		2999	if @{ $self->{children} };
		3000
		3001	$self
		3002	}
		3003
		3004	sub add {
		3005	my ($self, @widgets) = @_;
		3006
		3007	$self->SUPER::add (@widgets);
		3008
		3009	$self->{current} = $self->{children}[0]
		3010	if @{ $self->{children} };
		3011	}
		3012
		3013	sub set_current_page {
		3014	my ($self, $page_or_widget) = @_;
		3015
		3016	my $widget = ref $page_or_widget
		3017	? $page_or_widget
		3018	: $self->{children}[$page_or_widget];
		3019
		3020	$self->{current} = $widget;
		3021	$self->{current}->configure (0, 0, $self->{w}, $self->{h});
		3022
		3023	$self->_emit (page_changed => $self->{current});
		3024
		3025	$self->realloc;
		3026	}
		3027
		3028	sub visible_children {
		3029	$_[0]{current}
		3030	}
		3031
		3032	sub size_request {
		3033	my ($self) = @_;
		3034
		3035	$self->{current}->size_request
		3036	}
		3037
		3038	sub size_allocate {
		3039	my ($self, $w, $h) = @_;
		3040
		3041	$self->{current}->configure (0, 0, $w, $h);
		3042	}
		3043
		3044	sub _draw {
		3045	my ($self) = @_;
		3046
		3047	$self->{current}->draw;
		3048	}
		3049
		3050	#############################################################################
		3051
		3052	package CFClient::UI::Notebook;
		3053
		3054	our @ISA = CFClient::UI::VBox::;
		3055
		3056	sub new {
		3057	my $class = shift;
		3058
		3059	my $self = $class->SUPER::new (
		3060	buttonbar => (new CFClient::UI::Buttonbar),
		3061	multiplexer => (new CFClient::UI::Multiplexer expand => 1),
		3062	# filter => # will be put between multiplexer and $self
		3063	@_,
		3064	);
		3065
		3066	$self->{filter}->add ($self->{multiplexer}) if $self->{filter};
		3067	$self->SUPER::add ($self->{buttonbar}, $self->{filter} || $self->{multiplexer});
		3068
		3069	$self
		3070	}
		3071
		3072	sub add {
		3073	my ($self, $title, $widget, $tooltip) = @_;
		3074
		3075	Scalar::Util::weaken $self;
		3076
		3077	$self->{buttonbar}->add (new CFClient::UI::Button
		3078	markup => $title,
		3079	tooltip => $tooltip,
		3080	on_activate => sub { $self->set_current_page ($widget) },
		3081	);
		3082
		3083	$self->{multiplexer}->add ($widget);
		3084	}
		3085
		3086	sub set_current_page {
		3087	my ($self, $page) = @_;
		3088
		3089	$self->{multiplexer}->set_current_page ($page);
		3090	$self->_emit (page_changed => $self->{multiplexer}{current});
		3091	}
		3092
		3093	#############################################################################
		3094
		3095	package CFClient::UI::Combobox;
		3096
		3097	use utf8;
		3098
		3099	our @ISA = CFClient::UI::Button::;
		3100
		3101	sub new {
		3102	my $class = shift;
		3103
		3104	my $self = $class->SUPER::new (
		3105	options => [], # [title, value, tooltip], ...
		3106	value => undef,
		3107	@_,
		3108	);
		3109
		3110	$self->_set_value ($self->{value});
		3111
		3112	$self
		3113	}
		3114
		3115	sub button_down {
		3116	my ($self, $ev) = @_;
		3117
		3118	my @menu_items;
		3119
		3120	for (@{ $self->{options} }) {
		3121	my ($title, $value, $tooltip) = @$_;
		3122
		3123	push @menu_items, [$tooltip, sub { $self->set_value ($value) }];
		3124	}
		3125
		3126	CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev);
		3127	}
		3128
		3129	sub _set_value {
		3130	my ($self, $value) = @_;
		3131
		3132	my ($item) = grep $_->[1] eq $value, @{ $self->{options} }
		3133	or return;
		3134
		3135	$self->{value} = $item->[1];
		3136	$self->set_markup ("$item->[0] ⇓");
		3137	$self->set_tooltip ($item->[2]);
		3138	}
		3139
		3140	sub set_value {
		3141	my ($self, $value) = @_;
		3142
		3143	return unless $self->{value} ne $value;
		3144
		3145	$self->_set_value ($value);
		3146	$self->_emit (changed => $value);
		3147	}
		3148
		3149	#############################################################################
		3150
2649	package CFClient::UI::Statusbox;	3151	package CFClient::UI::Statusbox;
2650		3152
2651	our @ISA = CFClient::UI::VBox::;	3153	our @ISA = CFClient::UI::VBox::;
2652		3154
		3155	sub new {
		3156	my $class = shift;
		3157
		3158	my $self = $class->SUPER::new (
		3159	fontsize => 0.8,
		3160	@_,
		3161	);
		3162
		3163	Scalar::Util::weaken (my $this = $self);
		3164
		3165	$self->{timer} = Event->timer (after => 1, interval => 1, cb => sub { $this->reorder });
		3166
		3167	$self
		3168	}
		3169
2653	sub reorder {	3170	sub reorder {
2654	my ($self) = @_;	3171	my ($self) = @_;
2655	my $NOW = time;	3172	my $NOW = Time::HiRes::time;
		3173
		3174	# freeze display when hovering over any label
		3175	return if $CFClient::UI::TOOLTIP->{owner}
		3176	&& grep $CFClient::UI::TOOLTIP->{owner} == $_->{label},
		3177	values %{ $self->{item} };
2656		3178
2657	while (my ($k, $v) = each %{ $self->{item} }) {	3179	while (my ($k, $v) = each %{ $self->{item} }) {
2658	delete $self->{item}{$k} if $v->{timeout} < $NOW;	3180	delete $self->{item}{$k} if $v->{timeout} < $NOW;
2659	}	3181	}
2660		3182
2661	my @widgets;	3183	my @widgets;
2662	my @items = sort { $a->{time} <=> $b->{time} } values %{ $self->{item} };	3184
		3185	my @items = sort {
		3186	$a->{pri} <=> $b->{pri}
		3187	or $b->{id} <=> $a->{id}
		3188	} values %{ $self->{item} };
		3189
		3190	$self->{timer}->interval (1);
		3191
2663	my $count = 10 + 1;	3192	my $count = 10 + 1;
2664	for my $item (@items) {	3193	for my $item (@items) {
2665	last unless --$count;	3194	last unless --$count;
2666		3195
2667	push @widgets, $item->{label} ||= do {	3196	my $label = $item->{label} ||= do {
2668	# TODO: doesn't handle markup well (read as: at all)	3197	# TODO: doesn't handle markup well (read as: at all)
2669	my $short = delete $item->{text};	3198	my $short = $item->{count} > 1
		3199	? "<b>$item->{count} ×</b> $item->{text}"
		3200	: $item->{text};
		3201
2670	for ($short) {	3202	for ($short) {
2671	s/^\s+//;	3203	s/^\s+//;
2672	s/\012.*//s;	3204	s/\s+/ /g;
2673	my $len = int 30 / $item->{fontsize};
2674	substr $_, $len, length, "…" if $len < length;
2675	}	3205	}
2676		3206
2677	new CFClient::UI::Label	3207	new CFClient::UI::Label
2678	markup => $short,	3208	markup => $short,
2679	tooltip => delete $item->{tooltip},	3209	tooltip => $item->{tooltip},
2680	fontsize => delete $item->{fontsize},	3210	tooltip_font => $::FONT_PROP,
2681	color => delete $item->{color},	3211	tooltip_width => 0.67,
		3212	fontsize => $item->{fontsize} || $self->{fontsize},
		3213	max_w => $::WIDTH * 0.44,
		3214	fg => [@{ $item->{fg} }],
2682	can_events => 1,	3215	can_events => 1,
2683	can_hover => 1,	3216	can_hover => 1
2684	};	3217	};
		3218
		3219	if ((my $diff = $item->{timeout} - $NOW) < 2) {
		3220	$label->{fg}[3] = ($item->{fg}[3] || 1) * $diff / 2;
		3221	$label->update;
		3222	$label->set_max_size (undef, $label->{req_h} * $diff)
		3223	if $diff < 1;
		3224	$self->{timer}->interval (1/30);
		3225	} else {
		3226	$label->{fg}[3] = $item->{fg}[3] || 1;
		3227	}
		3228
		3229	push @widgets, $label;
2685	}	3230	}
2686		3231
2687	$self->clear;	3232	$self->clear;
2688	$self->SUPER::add (@widgets);	3233	$self->SUPER::add (reverse @widgets);
2689	}	3234	}
2690		3235
2691	sub add {	3236	sub add {
2692	my ($self, $text, %arg) = @_;	3237	my ($self, $text, %arg) = @_;
2693		3238
2694	my $item = {	3239	$text =~ s/^\s+//;
2695	time => time,	3240	$text =~ s/\s+$//;
		3241
		3242	return unless $text;
		3243
		3244	my $timeout = (int time) + ((delete $arg{timeout}) || 60);
		3245
		3246	my $group = exists $arg{group} ? $arg{group} : ++$self->{id};
		3247
		3248	if (my $item = $self->{item}{$group}) {
		3249	if ($item->{text} eq $text) {
		3250	$item->{count}++;
		3251	} else {
		3252	$item->{count} = 1;
		3253	$item->{text} = $item->{tooltip} = $text;
		3254	}
		3255	$item->{id} = ++$self->{id};
		3256	$item->{timeout} = $timeout;
		3257	delete $item->{label};
		3258	} else {
		3259	$self->{item}{$group} = {
		3260	id => ++$self->{id},
2696	text => $text,	3261	text => $text,
2697	timeout => 60,	3262	timeout => $timeout,
2698	tooltip => $text,	3263	tooltip => $text,
2699	fontsize => 0.8,
2700	color => [0.8, 0.8, 0.8, 0.8],	3264	fg => [0.8, 0.8, 0.8, 0.8],
		3265	pri => 0,
		3266	count => 1,
2701	%arg,	3267	%arg,
		3268	};
2702	};	3269	}
2703
2704	$item->{timeout} += time;
2705	$item->{group} ||= $item+0;
2706
2707	$item = $self->{item}{$item->{group}} ||= $item;
2708		3270
2709	$self->reorder;	3271	$self->reorder;
2710	}	3272	}
2711		3273
		3274	sub reconfigure {
		3275	my ($self) = @_;
		3276
		3277	delete $_->{label}
		3278	for values %{ $self->{item} || {} };
		3279
		3280	$self->reorder;
		3281	$self->SUPER::reconfigure;
		3282	}
		3283
		3284	sub DESTROY {
		3285	my ($self) = @_;
		3286
		3287	$self->{timer}->cancel;
		3288
		3289	$self->SUPER::DESTROY;
		3290	}
		3291
2712	#############################################################################	3292	#############################################################################
2713		3293
2714	package CFClient::UI::Root;	3294	package CFClient::UI::Inventory;
2715		3295
2716	our @ISA = CFClient::UI::Container::;	3296	our @ISA = CFClient::UI::ScrolledWindow::;
2717
2718	use CFClient::OpenGL;
2719		3297
2720	sub new {	3298	sub new {
2721	my $class = shift;	3299	my $class = shift;
2722		3300
2723	$class->SUPER::new (	3301	my $self = $class->SUPER::new (
		3302	child => (new CFClient::UI::Table col_expand => [0, 1, 0]),
		3303	@_,
		3304	);
		3305
		3306	$self
		3307	}
		3308
		3309	sub set_items {
		3310	my ($self, $items) = @_;
		3311
		3312	$self->{child}->clear;
		3313	return unless $items;
		3314
		3315	my @items = sort {
		3316	($a->{type} <=> $b->{type})
		3317	or ($a->{name} cmp $b->{name})
		3318	} @$items;
		3319
		3320	$self->{real_items} = \@items;
		3321
		3322	my $row = 0;
		3323	for my $item (@items) {
		3324	CFClient::Item::update_widgets $item;
		3325
		3326	$self->{child}->add (0, $row, $item->{face_widget});
		3327	$self->{child}->add (1, $row, $item->{desc_widget});
		3328	$self->{child}->add (2, $row, $item->{weight_widget});
		3329
		3330	$row++;
		3331	}
		3332	}
		3333
		3334	#############################################################################
		3335
		3336	package CFClient::UI::BindEditor;
		3337
		3338	our @ISA = CFClient::UI::FancyFrame::;
		3339
		3340	sub new {
		3341	my $class = shift;
		3342
		3343	my $self = $class->SUPER::new (binding => [], commands => [], @_);
		3344
		3345	$self->add (my $vb = new CFClient::UI::VBox);
		3346
		3347
		3348	$vb->add ($self->{rec_btn} = new CFClient::UI::Button
		3349	text => "start recording",
		3350	tooltip => "Start/Stops recording of actions."
		3351	."All subsequent actions after the recording started will be captured."
		3352	."The actions are displayed after the record was stopped."
		3353	."To bind the action you have to click on the 'Bind' button",
		3354	on_activate => sub {
		3355	unless ($self->{recording}) {
		3356	$self->start;
		3357	} else {
		3358	$self->stop;
		3359	}
		3360	});
		3361
		3362	$vb->add (new CFClient::UI::Label text => "Actions:");
		3363	$vb->add ($self->{cmdbox} = new CFClient::UI::VBox);
		3364
		3365	$vb->add (new CFClient::UI::Label text => "Bound to: ");
		3366	$vb->add (my $hb = new CFClient::UI::HBox);
		3367	$hb->add ($self->{keylbl} = new CFClient::UI::Label expand => 1);
		3368	$hb->add (new CFClient::UI::Button
		3369	text => "bind",
		3370	tooltip => "This opens a query where you have to press the key combination to bind the recorded actions",
		3371	on_activate => sub {
		3372	$self->ask_for_bind;
		3373	});
		3374
		3375	$vb->add (my $hb = new CFClient::UI::HBox);
		3376	$hb->add (new CFClient::UI::Button
		3377	text => "ok",
		3378	expand => 1,
		3379	tooltip => "This closes the binding editor and saves the binding",
		3380	on_activate => sub {
		3381	$self->hide;
		3382	$self->commit;
		3383	});
		3384
		3385	$hb->add (new CFClient::UI::Button
		3386	text => "cancel",
		3387	expand => 1,
		3388	tooltip => "This closes the binding editor without saving",
		3389	on_activate => sub {
		3390	$self->hide;
		3391	$self->{binding_cancel}->()
		3392	if $self->{binding_cancel};
		3393	});
		3394
		3395	$self->update_binding_widgets;
		3396
		3397	$self
		3398	}
		3399
		3400	sub commit {
		3401	my ($self) = @_;
		3402	my ($mod, $sym, $cmds) = $self->get_binding;
		3403	if ($sym != 0 && @$cmds > 0) {
		3404	$::STATUSBOX->add ("Bound actions to '".CFClient::Binder::keycombo_to_name ($mod, $sym)
		3405	."'. Don't forget 'Save Config'!");
		3406	$self->{binding_change}->($mod, $sym, $cmds)
		3407	if $self->{binding_change};
		3408	} else {
		3409	$::STATUSBOX->add ("No action bound, no key or action specified!");
		3410	$self->{binding_cancel}->()
		3411	if $self->{binding_cancel};
		3412	}
		3413	}
		3414
		3415	sub start {
		3416	my ($self) = @_;
		3417
		3418	$self->{rec_btn}->set_text ("stop recording");
		3419	$self->{recording} = 1;
		3420	$self->clear_command_list;
		3421	$::CONN->start_record if $::CONN;
		3422	}
		3423
		3424	sub stop {
		3425	my ($self) = @_;
		3426
		3427	$self->{rec_btn}->set_text ("start recording");
		3428	$self->{recording} = 0;
		3429
		3430	my $rec;
		3431	$rec = $::CONN->stop_record if $::CONN;
		3432	return unless ref $rec eq 'ARRAY';
		3433	$self->set_command_list ($rec);
		3434	}
		3435
		3436
		3437	sub ask_for_bind_and_commit {
		3438	my ($self) = @_;
		3439	$self->ask_for_bind (1);
		3440	}
		3441
		3442	sub ask_for_bind {
		3443	my ($self, $commit) = @_;
		3444
		3445	CFClient::Binder::open_binding_dialog (sub {
		3446	my ($mod, $sym) = @_;
		3447	$self->{binding} = [$mod, $sym]; # XXX: how to stop that memleak?
		3448	$self->update_binding_widgets;
		3449	$self->commit if $commit;
		3450	});
		3451	}
		3452
		3453	# $mod and $sym are the modifiers and key symbol
		3454	# $cmds is a array ref of strings (the commands)
		3455	# $cb is the callback that is executed on OK
		3456	# $ccb is the callback that is executed on CANCEL and
		3457	# when the binding was unsuccessful on OK
		3458	sub set_binding {
		3459	my ($self, $mod, $sym, $cmds, $cb, $ccb) = @_;
		3460
		3461	$self->clear_command_list;
		3462	$self->{recording} = 0;
		3463	$self->{rec_btn}->set_text ("start recording");
		3464
		3465	$self->{binding} = [$mod, $sym];
		3466	$self->{commands} = $cmds;
		3467
		3468	$self->{binding_change} = $cb;
		3469	$self->{binding_cancel} = $ccb;
		3470
		3471	$self->update_binding_widgets;
		3472	}
		3473
		3474	# this is a shortcut method that asks for a binding
		3475	# and then just binds it.
		3476	sub do_quick_binding {
		3477	my ($self, $cmds) = @_;
		3478	$self->set_binding (undef, undef, $cmds, sub {
		3479	$::CFG->{bindings}->{$_[0]}->{$_[1]} = $_[2];
		3480	});
		3481	$self->ask_for_bind (1);
		3482	}
		3483
		3484	sub update_binding_widgets {
		3485	my ($self) = @_;
		3486	my ($mod, $sym, $cmds) = $self->get_binding;
		3487	$self->{keylbl}->set_text (CFClient::Binder::keycombo_to_name ($mod, $sym));
		3488	$self->set_command_list ($cmds);
		3489	}
		3490
		3491	sub get_binding {
		3492	my ($self) = @_;
		3493	return (
		3494	$self->{binding}->[0],
		3495	$self->{binding}->[1],
		3496	[ grep { defined $_ } @{$self->{commands}} ]
		3497	);
		3498	}
		3499
		3500	sub clear_command_list {
		3501	my ($self) = @_;
		3502	$self->{cmdbox}->clear ();
		3503	}
		3504
		3505	sub set_command_list {
		3506	my ($self, $cmds) = @_;
		3507
		3508	$self->{cmdbox}->clear ();
		3509	$self->{commands} = $cmds;
		3510
		3511	my $idx = 0;
		3512
		3513	for (@$cmds) {
		3514	$self->{cmdbox}->add (my $hb = new CFClient::UI::HBox);
		3515
		3516	my $i = $idx;
		3517	$hb->add (new CFClient::UI::Label text => $_);
		3518	$hb->add (new CFClient::UI::Button
		3519	text => "delete",
		3520	tooltip => "Deletes the action from the record",
		3521	on_activate => sub {
		3522	$self->{cmdbox}->remove ($hb);
		3523	$cmds->[$i] = undef;
		3524	});
		3525
		3526
		3527	$idx++
		3528	}
		3529	}
		3530
		3531	#############################################################################
		3532
		3533	package CFClient::UI::SpellList;
		3534
		3535	our @ISA = CFClient::UI::Table::;
		3536
		3537	sub new {
		3538	my $class = shift;
		3539
		3540	my $self = $class->SUPER::new (
		3541	binding => [],
		3542	commands => [],
2724	@_,	3543	@_,
2725	)	3544	)
2726	}	3545	}
2727		3546
2728	sub configure {	3547	my @TOOLTIP_LVL = (align => 1, can_events => 1, can_hover => 1, tooltip =>
2729	my ($self, $x, $y, $w, $h) = @_;	3548	"<b>Level</b>. Minimum level the caster needs in the associated skill to be able to attempt casting this spell.");
		3549	my @TOOLTIP_SP = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3550	"<b>Spell points / Grace points</b>. Amount of spell or grace points used by each invocation.");
		3551	my @TOOLTIP_DMG = (align => 1, can_events => 1, can_hover => 1, tooltip =>
		3552	"<b>Damage</b>. The amount of damage the spell deals when it hits.");
2730		3553
2731	$self->{w} = $w;	3554	sub rebuild_spell_list {
2732	$self->{h} = $h;	3555	my ($self) = @_;
2733	}
2734		3556
2735	sub check_size {	3557	$CFClient::UI::ROOT->on_refresh ($self => sub {
		3558	$self->clear;
		3559
		3560	$self->add (1, 0, new CFClient::UI::Label text => "Spell Name");
		3561	$self->add (2, 0, new CFClient::UI::Label text => "Lvl" , @TOOLTIP_LVL);
		3562	$self->add (3, 0, new CFClient::UI::Label text => "Sp/Gp", @TOOLTIP_SP);
		3563	$self->add (4, 0, new CFClient::UI::Label text => "Dmg" , @TOOLTIP_DMG);
		3564
		3565	my $row = 0;
		3566
		3567	for (sort { $a cmp $b } keys %{ $self->{spell} }) {
		3568	my $spell = $self->{spell}{$_};
		3569
		3570	$row++;
		3571
		3572	$self->add (0, $row, new CFClient::UI::Face
		3573	face => $spell->{face},
		3574	can_hover => 1,
		3575	can_events => 1,
		3576	tooltip => $spell->{message},
		3577	);
		3578
		3579	$self->add (1, $row, new CFClient::UI::Label
		3580	expand => 1,
		3581	text => $spell->{name},
		3582	can_hover => 1,
		3583	can_events => 1,
		3584	tooltip => $spell->{message},
		3585	);
		3586
		3587	$self->add (2, $row, new CFClient::UI::Label text => $spell->{level}, @TOOLTIP_LVL);
		3588	$self->add (3, $row, new CFClient::UI::Label text => $spell->{mana} || $spell->{grace}, @TOOLTIP_SP);
		3589	$self->add (4, $row, new CFClient::UI::Label text => $spell->{damage}, @TOOLTIP_DMG);
		3590
		3591	# TODO: should be done via popup
		3592	$self->add (5, $row, new CFClient::UI::Button
		3593	text => "bind",
		3594	tooltip => "bind spell readying (cast command) to key",
		3595	on_activate => sub { $::BIND_EDITOR->do_quick_binding (["cast $spell->{name}"]) },
		3596	);
		3597	}
		3598	});
		3599	}
		3600
		3601	sub add_spell {
2736	my ($self) = @_;	3602	my ($self, $spell) = @_;
2737		3603
2738	$self->size_allocate ($self->{w}, $self->{h})	3604	$self->{spell}->{$spell->{name}} = $spell;
2739	if $self->{w};	3605	$self->rebuild_spell_list;
		3606	}
		3607
		3608	sub remove_spell {
		3609	my ($self, $spell) = @_;
		3610
		3611	delete $self->{spell}->{$spell->{name}};
		3612	$self->rebuild_spell_list;
		3613	}
		3614
		3615	#############################################################################
		3616
		3617	package CFClient::UI::Root;
		3618
		3619	our @ISA = CFClient::UI::Container::;
		3620
		3621	use List::Util qw(min max);
		3622
		3623	use CFClient::OpenGL;
		3624
		3625	sub new {
		3626	my $class = shift;
		3627
		3628	my $self = $class->SUPER::new (
		3629	visible => 1,
		3630	@_,
		3631	);
		3632
		3633	Scalar::Util::weaken ($self->{root} = $self);
		3634
		3635	$self
2740	}	3636	}
2741		3637
2742	sub size_request {	3638	sub size_request {
2743	my ($self) = @_;	3639	my ($self) = @_;
2744		3640
2745	($self->{w}, $self->{h})	3641	($self->{w}, $self->{h})
		3642	}
		3643
		3644	sub _to_pixel {
		3645	my ($coord, $size, $max) = @_;
		3646
		3647	$coord =
		3648	$coord eq "center" ? ($max - $size) * 0.5
		3649	: $coord eq "max" ? $max
		3650	: $coord;
		3651
		3652	$coord = 0 if $coord < 0;
		3653	$coord = $max - $size if $coord > $max - $size;
		3654
		3655	int $coord + 0.5
2746	}	3656	}
2747		3657
2748	sub size_allocate {	3658	sub size_allocate {
2749	my ($self, $w, $h) = @_;	3659	my ($self, $w, $h) = @_;
2750		3660
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) {	3661	for my $child ($self->children) {
2768	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};	3662	my ($X, $Y, $W, $H) = @$child{qw(x y req_w req_h)};
2769		3663
2770	$X = List::Util::max 0, List::Util::min $w - $W, $X;	3664	$X = $child->{force_x} if exists $child->{force_x};
2771	$Y = List::Util::max 0, List::Util::min $h - $H, $Y;	3665	$Y = $child->{force_y} if exists $child->{force_y};
		3666
		3667	$X = _to_pixel $X, $W, $self->{w};
		3668	$Y = _to_pixel $Y, $H, $self->{h};
		3669
2772	$child->configure ($X, $Y, $W, $H);	3670	$child->configure ($X, $Y, $W, $H);
2773	}	3671	}
2774
2775	$self->{old_w} = $w;
2776	$self->{old_h} = $h;
2777	}	3672	}
2778		3673
2779	sub coord2local {	3674	sub coord2local {
2780	my ($self, $x, $y) = @_;	3675	my ($self, $x, $y) = @_;
2781		3676
…		…
2789	}	3684	}
2790		3685
2791	sub update {	3686	sub update {
2792	my ($self) = @_;	3687	my ($self) = @_;
2793		3688
2794	$self->check_size;
2795	$::WANT_REFRESH++;	3689	$::WANT_REFRESH++;
2796	}	3690	}
2797		3691
2798	sub add {	3692	sub add {
2799	my ($self, $child) = @_;	3693	my ($self, @children) = @_;
2800		3694
2801	# integerise window positions	3695	$_->{is_toplevel} = 1
2802	$child->{x} = int $child->{x};	3696	for @children;
2803	$child->{y} = int $child->{y};
2804		3697
2805	$self->SUPER::add ($child);	3698	$self->SUPER::add (@children);
		3699	}
		3700
		3701	sub remove {
		3702	my ($self, @children) = @_;
		3703
		3704	$self->SUPER::remove (@children);
		3705
		3706	delete $self->{is_toplevel}
		3707	for @children;
		3708
		3709	while (@children) {
		3710	my $w = pop @children;
		3711	push @children, $w->children;
		3712	$w->set_invisible;
		3713	}
2806	}	3714	}
2807		3715
2808	sub on_refresh {	3716	sub on_refresh {
2809	my ($self, $id, $cb) = @_;	3717	my ($self, $id, $cb) = @_;
2810		3718
2811	$self->{refresh_hook}{$id} = $cb;	3719	$self->{refresh_hook}{$id} = $cb;
2812	}	3720	}
2813		3721
		3722	sub on_post_alloc {
		3723	my ($self, $id, $cb) = @_;
		3724
		3725	$self->{post_alloc_hook}{$id} = $cb;
		3726	}
		3727
2814	sub draw {	3728	sub draw {
2815	my ($self) = @_;	3729	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		3730
2861	while ($self->{refresh_hook}) {	3731	while ($self->{refresh_hook}) {
2862	$_->()	3732	$_->()
2863	for values %{delete $self->{refresh_hook}};	3733	for values %{delete $self->{refresh_hook}};
2864	}	3734	}
2865		3735
		3736	if ($self->{realloc}) {
		3737	my %queue;
		3738	my @queue;
		3739	my $widget;
		3740
		3741	outer:
		3742	while () {
		3743	if (my $realloc = delete $self->{realloc}) {
		3744	for $widget (values %$realloc) {
		3745	$widget->{visible} or next; # do not resize invisible widgets
		3746
		3747	$queue{$widget+0}++ and next; # duplicates are common
		3748
		3749	push @{ $queue[$widget->{visible}] }, $widget;
		3750	}
		3751	}
		3752
		3753	while () {
		3754	@queue or last outer;
		3755
		3756	$widget = pop @{ $queue[-1] || [] }
		3757	and last;
		3758
		3759	pop @queue;
		3760	}
		3761
		3762	delete $queue{$widget+0};
		3763
		3764	my ($w, $h) = $widget->size_request;
		3765
		3766	$w = max $widget->{min_w}, $w + $widget->{padding_x} * 2;
		3767	$h = max $widget->{min_h}, $h + $widget->{padding_y} * 2;
		3768
		3769	$w = min $widget->{max_w}, $w if exists $widget->{max_w};
		3770	$h = min $widget->{max_h}, $h if exists $widget->{max_h};
		3771
		3772	$w = $widget->{force_w} if exists $widget->{force_w};
		3773	$h = $widget->{force_h} if exists $widget->{force_h};
		3774
		3775	if ($widget->{req_w} != $w || $widget->{req_h} != $h
		3776	|| delete $widget->{force_realloc}) {
		3777	$widget->{req_w} = $w;
		3778	$widget->{req_h} = $h;
		3779
		3780	$self->{size_alloc}{$widget+0} = $widget;
		3781
		3782	if (my $parent = $widget->{parent}) {
		3783	$self->{realloc}{$parent+0} = $parent
		3784	unless $queue{$parent+0};
		3785
		3786	$parent->{force_size_alloc} = 1;
		3787	$self->{size_alloc}{$parent+0} = $parent;
		3788	}
		3789	}
		3790
		3791	delete $self->{realloc}{$widget+0};
		3792	}
		3793	}
		3794
		3795	while (my $size_alloc = delete $self->{size_alloc}) {
		3796	my @queue = sort { $b->{visible} <=> $a->{visible} }
		3797	values %$size_alloc;
		3798
		3799	while () {
		3800	my $widget = pop @queue || last;
		3801
		3802	my ($w, $h) = @$widget{qw(alloc_w alloc_h)};
		3803
		3804	$w = 0 if $w < 0;
		3805	$h = 0 if $h < 0;
		3806
		3807	$w = int $w + 0.5;
		3808	$h = int $h + 0.5;
		3809
		3810	if ($widget->{w} != $w || $widget->{h} != $h || delete $widget->{force_size_alloc}) {
		3811	$widget->{old_w} = $widget->{w};
		3812	$widget->{old_h} = $widget->{h};
		3813
		3814	$widget->{w} = $w;
		3815	$widget->{h} = $h;
		3816
		3817	$widget->emit (size_allocate => $w, $h);
		3818	}
		3819	}
		3820	}
		3821
		3822	while ($self->{post_alloc_hook}) {
		3823	$_->()
		3824	for values %{delete $self->{post_alloc_hook}};
		3825	}
		3826
		3827
2866	glViewport 0, 0, $::WIDTH, $::HEIGHT;	3828	glViewport 0, 0, $::WIDTH, $::HEIGHT;
2867	glClearColor +($::CFG->{fow_intensity}) x 3, 1;	3829	glClearColor +($::CFG->{fow_intensity}) x 3, 1;
2868	glClear GL_COLOR_BUFFER_BIT;	3830	glClear GL_COLOR_BUFFER_BIT;
2869		3831
2870	glMatrixMode GL_PROJECTION;	3832	glMatrixMode GL_PROJECTION;
2871	glLoadIdentity;	3833	glLoadIdentity;
2872	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000 , 10000;	3834	glOrtho 0, $::WIDTH, $::HEIGHT, 0, -10000, 10000;
2873	glMatrixMode GL_MODELVIEW;	3835	glMatrixMode GL_MODELVIEW;
2874	glLoadIdentity;	3836	glLoadIdentity;
2875		3837
		3838	{
		3839	package CFClient::UI::Base;
		3840
		3841	($draw_x, $draw_y, $draw_w, $draw_h) =
		3842	(0, 0, $self->{w}, $self->{h});
		3843	}
		3844
2876	$self->_draw;	3845	$self->_draw;
2877	}	3846	}
2878		3847
2879	#############################################################################	3848	#############################################################################
2880		3849
2881	package CFClient::UI;	3850	package CFClient::UI;
2882		3851
2883	$ROOT = new CFClient::UI::Root;	3852	$ROOT = new CFClient::UI::Root;
2884	$TOOLTIP = new CFClient::UI::Tooltip;	3853	$TOOLTIP = new CFClient::UI::Tooltip z => 900;
2885		3854
2886	1	3855	1
2887		3856

Diff Legend

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