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.211 by elmex, Wed May 17 10:33:03 2006 UTC vs.
Revision 1.303 by elmex, Tue Jun 13 10:28:38 2006 UTC

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

Diff Legend

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