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.150 by elmex, Sun Apr 23 00:08:29 2006 UTC vs.
Revision 1.268 by root, Thu Jun 1 05:04:41 2006 UTC

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

Diff Legend

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