ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC/UI.pm
Revision: 1.292
Committed: Tue Jun 6 03:02:15 2006 UTC (18 years ago) by root
Branch: MAIN
Changes since 1.291: +4 -0 lines
Log Message:
tune message box text wrapping a bit

File Contents

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