1 | package DC::UI; |
1 | package DC::UI; |
2 | |
2 | |
3 | use utf8; |
3 | use common::sense; |
4 | use strict; |
|
|
5 | |
4 | |
6 | use List::Util (); |
5 | use List::Util (); |
|
|
6 | |
|
|
7 | use AnyEvent (); |
|
|
8 | use Guard (); |
7 | |
9 | |
8 | use DC; |
10 | use DC; |
9 | use DC::Pod; |
11 | use DC::Pod; |
10 | use DC::Texture; |
12 | use DC::Texture; |
11 | |
13 | |
… | |
… | |
50 | sub get_layout { |
52 | sub get_layout { |
51 | my $layout; |
53 | my $layout; |
52 | |
54 | |
53 | for (grep { $_->{name} } values %WIDGET) { |
55 | for (grep { $_->{name} } values %WIDGET) { |
54 | my $win = $layout->{$_->{name}} = { }; |
56 | my $win = $layout->{$_->{name}} = { }; |
55 | |
57 | |
56 | $win->{x} = ($_->{x} + $_->{w} * 0.5) / $::WIDTH if $_->{x} =~ /^[0-9.]+$/; |
58 | $win->{x} = ($_->{x} + $_->{w} * 0.5) / $::WIDTH if $_->{x} =~ /^[0-9.]+$/; |
57 | $win->{y} = ($_->{y} + $_->{h} * 0.5) / $::HEIGHT if $_->{y} =~ /^[0-9.]+$/; |
59 | $win->{y} = ($_->{y} + $_->{h} * 0.5) / $::HEIGHT if $_->{y} =~ /^[0-9.]+$/; |
58 | $win->{w} = $_->{w} / $::WIDTH if defined $_->{w}; |
60 | $win->{w} = $_->{w} / $::WIDTH if defined $_->{w}; |
59 | $win->{h} = $_->{h} / $::HEIGHT if defined $_->{h}; |
61 | $win->{h} = $_->{h} / $::HEIGHT if defined $_->{h}; |
60 | |
62 | |
… | |
… | |
69 | |
71 | |
70 | $LAYOUT = $layout; |
72 | $LAYOUT = $layout; |
71 | } |
73 | } |
72 | |
74 | |
73 | # class methods for events |
75 | # class methods for events |
74 | sub feed_sdl_key_down_event { |
76 | sub feed_sdl_key_down_event { |
75 | $FOCUS->emit (key_down => $_[0]) |
77 | $FOCUS->emit (key_down => $_[0]) |
76 | if $FOCUS; |
78 | if $FOCUS; |
77 | } |
79 | } |
78 | |
80 | |
79 | sub feed_sdl_key_up_event { |
81 | sub feed_sdl_key_up_event { |
… | |
… | |
189 | # call when resolution changes etc. |
191 | # call when resolution changes etc. |
190 | sub rescale_widgets { |
192 | sub rescale_widgets { |
191 | my ($sx, $sy) = @_; |
193 | my ($sx, $sy) = @_; |
192 | |
194 | |
193 | for my $widget (values %WIDGET) { |
195 | for my $widget (values %WIDGET) { |
194 | if ($widget->{is_toplevel}) { |
196 | if ($widget->{is_toplevel} || $widget->{c_rescale}) { |
195 | $widget->{x} += int $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/; |
197 | $widget->{x} += int $widget->{w} * 0.5 if $widget->{x} =~ /^[0-9.]+$/; |
196 | $widget->{y} += int $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/; |
198 | $widget->{y} += int $widget->{h} * 0.5 if $widget->{y} =~ /^[0-9.]+$/; |
197 | |
199 | |
198 | $widget->{x} = int 0.5 + $widget->{x} * $sx if $widget->{x} =~ /^[0-9.]+$/; |
200 | $widget->{x} = int 0.5 + $widget->{x} * $sx if $widget->{x} =~ /^[0-9.]+$/; |
199 | $widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w}; |
201 | $widget->{w} = int 0.5 + $widget->{w} * $sx if exists $widget->{w}; |
… | |
… | |
221 | |
223 | |
222 | ############################################################################# |
224 | ############################################################################# |
223 | |
225 | |
224 | package DC::UI::Base; |
226 | package DC::UI::Base; |
225 | |
227 | |
226 | use strict; |
228 | use common::sense; |
227 | |
229 | |
228 | use DC::OpenGL; |
230 | use DC::OpenGL; |
229 | |
231 | |
230 | sub new { |
232 | sub new { |
231 | my $class = shift; |
233 | my $class = shift; |
… | |
… | |
286 | sub set_visible { |
288 | sub set_visible { |
287 | my ($self) = @_; |
289 | my ($self) = @_; |
288 | |
290 | |
289 | return if $self->{visible}; |
291 | return if $self->{visible}; |
290 | |
292 | |
|
|
293 | $self->{parent} && $self->{parent}{root}#d# |
|
|
294 | or return ::clienterror ("set_visible called without parent ($self->{parent}) or root\n" => 1); |
|
|
295 | |
291 | $self->{root} = $self->{parent}{root}; |
296 | $self->{root} = $self->{parent}{root}; |
292 | $self->{visible} = $self->{parent}{visible} + 1; |
297 | $self->{visible} = $self->{parent}{visible} + 1; |
293 | |
298 | |
294 | $self->emit (visibility_change => 1); |
299 | $self->emit (visibility_change => 1); |
295 | |
300 | |
296 | $self->realloc if !exists $self->{req_w}; |
301 | $self->realloc if !exists $self->{req_w}; |
297 | |
302 | |
298 | $_->set_visible for $self->children; |
303 | $_->set_visible for $self->visible_children; |
299 | } |
304 | } |
300 | |
305 | |
301 | sub set_invisible { |
306 | sub set_invisible { |
302 | my ($self) = @_; |
307 | my ($self) = @_; |
303 | |
308 | |
… | |
… | |
358 | } |
363 | } |
359 | |
364 | |
360 | sub set_size { |
365 | sub set_size { |
361 | my ($self, $w, $h) = @_; |
366 | my ($self, $w, $h) = @_; |
362 | |
367 | |
363 | $self->{force_w} = $w; |
368 | $self->{force_w} = List::Util::min $w, ($self->{max_w} || $::WIDTH ); |
364 | $self->{force_h} = $h; |
369 | $self->{force_h} = List::Util::min $h, ($self->{max_h} || $::HEIGHT); |
365 | |
370 | |
366 | $self->realloc; |
371 | $self->realloc; |
367 | } |
372 | } |
368 | |
373 | |
369 | # traverse the widget chain up to find the maximum "physical" size constraints |
374 | # traverse the widget chain up to find the maximum "physical" size constraints |
… | |
… | |
527 | sub connect { |
532 | sub connect { |
528 | my ($self, $signal, $cb) = @_; |
533 | my ($self, $signal, $cb) = @_; |
529 | |
534 | |
530 | push @{ $self->{signal_cb}{$signal} }, $cb; |
535 | push @{ $self->{signal_cb}{$signal} }, $cb; |
531 | |
536 | |
532 | defined wantarray and DC::guard { |
537 | defined wantarray and Guard::guard { |
533 | @{ $self->{signal_cb}{$signal} } = grep $_ != $cb, |
538 | @{ $self->{signal_cb}{$signal} } = grep $_ != $cb, |
534 | @{ $self->{signal_cb}{$signal} }; |
539 | @{ $self->{signal_cb}{$signal} }; |
535 | } |
540 | } |
536 | } |
541 | } |
537 | |
542 | |
… | |
… | |
638 | |
643 | |
639 | package DC::UI::DrawBG; |
644 | package DC::UI::DrawBG; |
640 | |
645 | |
641 | our @ISA = DC::UI::Base::; |
646 | our @ISA = DC::UI::Base::; |
642 | |
647 | |
643 | use strict; |
648 | use common::sense; |
|
|
649 | |
644 | use DC::OpenGL; |
650 | use DC::OpenGL; |
645 | |
651 | |
646 | sub new { |
652 | sub new { |
647 | my $class = shift; |
653 | my $class = shift; |
648 | |
654 | |
… | |
… | |
651 | #active_bg => [1, 1, 1, 0.5], |
657 | #active_bg => [1, 1, 1, 0.5], |
652 | @_ |
658 | @_ |
653 | ) |
659 | ) |
654 | } |
660 | } |
655 | |
661 | |
|
|
662 | sub set_bg { |
|
|
663 | my ($self, $bg) = @_; |
|
|
664 | |
|
|
665 | $self->{bg} = $bg; |
|
|
666 | $self->update; |
|
|
667 | } |
|
|
668 | |
656 | sub _draw { |
669 | sub _draw { |
657 | my ($self) = @_; |
670 | my ($self) = @_; |
658 | |
671 | |
659 | my $color = $FOCUS == $self && $self->{active_bg} |
672 | my $color = $FOCUS == $self |
660 | ? $self->{active_bg} |
673 | ? $self->{active_bg} || $self->{bg} |
661 | : $self->{bg}; |
674 | : $self->{bg}; |
662 | |
675 | |
663 | if ($color && (@$color < 4 || $color->[3])) { |
676 | if ($color && (@$color < 4 || $color->[3])) { |
664 | my ($w, $h) = @$self{qw(w h)}; |
677 | my ($w, $h) = @$self{qw(w h)}; |
665 | |
678 | |
… | |
… | |
1143 | |
1156 | |
1144 | $self->grab_focus; |
1157 | $self->grab_focus; |
1145 | |
1158 | |
1146 | my $ox = $self->{vp}{view_x}; |
1159 | my $ox = $self->{vp}{view_x}; |
1147 | my $oy = $self->{vp}{view_y}; |
1160 | my $oy = $self->{vp}{view_y}; |
1148 | |
1161 | |
1149 | $self->{motion} = sub { |
1162 | $self->{motion} = sub { |
1150 | my ($ev, $x, $y) = @_; |
1163 | my ($ev, $x, $y) = @_; |
1151 | |
1164 | |
1152 | $ox -= $ev->{xrel}; |
1165 | $ox -= $ev->{xrel}; |
1153 | $oy -= $ev->{yrel}; |
1166 | $oy -= $ev->{yrel}; |
… | |
… | |
1343 | |
1356 | |
1344 | our @ISA = DC::UI::Bin::; |
1357 | our @ISA = DC::UI::Bin::; |
1345 | |
1358 | |
1346 | use DC::OpenGL; |
1359 | use DC::OpenGL; |
1347 | |
1360 | |
1348 | my $bg = |
1361 | my $bg = |
1349 | new_from_resource DC::Texture "d1_bg.png", |
1362 | new_from_resource DC::Texture "d1_bg.png", |
1350 | mipmap => 1, wrap => 1; |
1363 | mipmap => 1, wrap => 1; |
1351 | |
1364 | |
1352 | my @border = |
1365 | my @border = |
1353 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
1366 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
1354 | qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png); |
1367 | qw(d1_border_top.png d1_border_right.png d1_border_left.png d1_border_bottom.png); |
1355 | |
1368 | |
1356 | my @icon = |
1369 | my @icon = |
1357 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
1370 | map { new_from_resource DC::Texture $_, mipmap => 1 } |
… | |
… | |
1361 | my ($class, %arg) = @_; |
1374 | my ($class, %arg) = @_; |
1362 | |
1375 | |
1363 | my $self = $class->SUPER::new ( |
1376 | my $self = $class->SUPER::new ( |
1364 | bg => [1, 1, 1, 1], |
1377 | bg => [1, 1, 1, 1], |
1365 | border_bg => [1, 1, 1, 1], |
1378 | border_bg => [1, 1, 1, 1], |
1366 | border => 1, |
1379 | border => 0.8, |
1367 | can_events => 1, |
1380 | can_events => 1, |
1368 | min_w => 64, |
1381 | min_w => 64, |
1369 | min_h => 32, |
1382 | min_h => 32, |
1370 | %arg, |
1383 | %arg, |
1371 | ); |
1384 | ); |
… | |
… | |
1451 | |
1464 | |
1452 | sub invoke_delete { |
1465 | sub invoke_delete { |
1453 | my ($self) = @_; |
1466 | my ($self) = @_; |
1454 | |
1467 | |
1455 | $self->hide; |
1468 | $self->hide; |
1456 | |
1469 | |
1457 | 1 |
1470 | 1 |
1458 | } |
1471 | } |
1459 | |
1472 | |
1460 | sub invoke_button_down { |
1473 | sub invoke_button_down { |
1461 | my ($self, $ev, $x, $y) = @_; |
1474 | my ($self, $ev, $x, $y) = @_; |
1462 | |
1475 | |
1463 | my ($w, $h) = @$self{qw(w h)}; |
1476 | my ($w, $h) = @$self{qw(w h)}; |
1464 | my $border = $self->border; |
1477 | my $border = $self->border; |
1465 | |
1478 | |
1466 | my $lr = ($x >= 0 && $x < $border) || ($x > $w - $border && $x < $w); |
1479 | my $lr = ($x >= 0 && $x < $border) || ($x > $w - $border && $x < $w); # left-right |
1467 | my $td = ($y >= 0 && $y < $border) || ($y > $h - $border && $y < $h); |
1480 | my $td = ($y >= 0 && $y < $border) || ($y > $h - $border && $y < $h); # top-down |
1468 | |
1481 | |
1469 | if ($lr & $td) { |
1482 | if ($lr & $td) { # corners |
1470 | my ($wx, $wy) = ($self->{x}, $self->{y}); |
1483 | my ($wx, $wy) = ($self->{x}, $self->{y}); |
1471 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1484 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1472 | my ($bw, $bh) = ($self->{w}, $self->{h}); |
1485 | my ($bw, $bh) = ($self->{w}, $self->{h}); |
1473 | |
1486 | |
1474 | my $mx = $x < $border; |
1487 | my $mx = $x < $border; |
… | |
… | |
1478 | my ($ev, $x, $y) = @_; |
1491 | my ($ev, $x, $y) = @_; |
1479 | |
1492 | |
1480 | my $dx = $ev->{x} - $ox; |
1493 | my $dx = $ev->{x} - $ox; |
1481 | my $dy = $ev->{y} - $oy; |
1494 | my $dy = $ev->{y} - $oy; |
1482 | |
1495 | |
|
|
1496 | $self->set_size ( |
1483 | $self->{force_w} = $bw + $dx * ($mx ? -1 : 1); |
1497 | $bw + $dx * ($mx ? -1 : 1), |
1484 | $self->{force_h} = $bh + $dy * ($my ? -1 : 1); |
1498 | $bh + $dy * ($my ? -1 : 1), |
|
|
1499 | ); |
1485 | |
1500 | |
1486 | $self->move_abs ($wx + $dx * $mx, $wy + $dy * $my); |
1501 | $self->move_abs ($wx + $dx * $mx, $wy + $dy * $my); |
1487 | $self->realloc; |
1502 | $self->realloc; |
1488 | }; |
1503 | }; |
1489 | |
1504 | |
1490 | } elsif ($lr ^ $td) { |
1505 | } elsif ($lr ^ $td) { # edges |
1491 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1506 | my ($ox, $oy) = ($ev->{x}, $ev->{y}); |
1492 | my ($bx, $by) = ($self->{x}, $self->{y}); |
1507 | my ($bx, $by) = ($self->{x}, $self->{y}); |
1493 | |
1508 | |
1494 | $self->{motion} = sub { |
1509 | $self->{motion} = sub { |
1495 | my ($ev, $x, $y) = @_; |
1510 | my ($ev, $x, $y) = @_; |
… | |
… | |
1540 | glEnable GL_TEXTURE_2D; |
1555 | glEnable GL_TEXTURE_2D; |
1541 | glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE; |
1556 | glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE; |
1542 | |
1557 | |
1543 | my $border = $self->border; |
1558 | my $border = $self->border; |
1544 | |
1559 | |
|
|
1560 | if ($border) { |
1545 | glColor @{ $self->{border_bg} }; |
1561 | glColor @{ $self->{border_bg} }; |
1546 | $border[0]->draw_quad_alpha ( 0, 0, $w, $border); |
1562 | $border[0]->draw_quad_alpha ( 0, 0, $w, $border); |
1547 | $border[1]->draw_quad_alpha ( 0, $border, $border, $ch); |
1563 | $border[1]->draw_quad_alpha ( 0, $border, $border, $ch); |
1548 | $border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch); |
1564 | $border[2]->draw_quad_alpha ($w - $border, $border, $border, $ch); |
1549 | $border[3]->draw_quad_alpha ( 0, $h - $border, $w, $border); |
1565 | $border[3]->draw_quad_alpha ( 0, $h - $border, $w, $border); |
1550 | |
1566 | |
1551 | # move |
1567 | # move |
1552 | my $w2 = ($w - $border) * .5; |
1568 | my $w2 = ($w - $border) * .5; |
1553 | my $h2 = ($h - $border) * .5; |
1569 | my $h2 = ($h - $border) * .5; |
1554 | $icon[0]->draw_quad_alpha ( 0, $h2, $border, $border); |
1570 | $icon[0]->draw_quad_alpha ( 0, $h2, $border, $border); |
1555 | $icon[0]->draw_quad_alpha ($w - $border, $h2, $border, $border); |
1571 | $icon[0]->draw_quad_alpha ($w - $border, $h2, $border, $border); |
1556 | $icon[0]->draw_quad_alpha ($w2 , $h - $border, $border, $border); |
1572 | $icon[0]->draw_quad_alpha ($w2 , $h - $border, $border, $border); |
1557 | |
1573 | |
1558 | # resize |
1574 | # resize |
1559 | $icon[1]->draw_quad_alpha ( 0, 0, $border, $border); |
1575 | $icon[1]->draw_quad_alpha ( 0, 0, $border, $border); |
1560 | $icon[1]->draw_quad_alpha ($w - $border, 0, $border, $border) |
1576 | $icon[1]->draw_quad_alpha ($w - $border, 0, $border, $border) |
1561 | unless $self->{has_close_button}; |
1577 | unless $self->{has_close_button}; |
1562 | $icon[1]->draw_quad_alpha ( 0, $h - $border, $border, $border); |
1578 | $icon[1]->draw_quad_alpha ( 0, $h - $border, $border, $border); |
1563 | $icon[1]->draw_quad_alpha ($w - $border, $h - $border, $border, $border); |
1579 | $icon[1]->draw_quad_alpha ($w - $border, $h - $border, $border, $border); |
|
|
1580 | } |
1564 | |
1581 | |
1565 | if (@{$self->{bg}} < 4 || $self->{bg}[3]) { |
1582 | if (@{$self->{bg}} < 4 || $self->{bg}[3]) { |
1566 | glColor @{ $self->{bg} }; |
1583 | glColor @{ $self->{bg} }; |
1567 | |
1584 | |
1568 | # TODO: repeat texture not scale |
1585 | # TODO: repeat texture not scale |
… | |
… | |
1823 | if ($req > $space) { |
1840 | if ($req > $space) { |
1824 | # ah well, not enough space |
1841 | # ah well, not enough space |
1825 | $_ *= $space / $req for @req; |
1842 | $_ *= $space / $req for @req; |
1826 | } else { |
1843 | } else { |
1827 | my $expand = (List::Util::sum map $_->{expand}, @children) || 1; |
1844 | my $expand = (List::Util::sum map $_->{expand}, @children) || 1; |
1828 | |
1845 | |
1829 | $space = ($space - $req) / $expand; # remaining space to give away |
1846 | $space = ($space - $req) / $expand; # remaining space to give away |
1830 | |
1847 | |
1831 | $req[$_] += $space * $children[$_]{expand} |
1848 | $req[$_] += $space * $children[$_]{expand} |
1832 | for 0 .. $#children; |
1849 | for 0 .. $#children; |
1833 | } |
1850 | } |
… | |
… | |
2062 | # $self->{list} = DC::OpenGL::glGenList; |
2079 | # $self->{list} = DC::OpenGL::glGenList; |
2063 | # DC::OpenGL::glNewList $self->{list}; |
2080 | # DC::OpenGL::glNewList $self->{list}; |
2064 | # $self->{layout}->render ($self->{ox}, $self->{oy}, $self->{style}); |
2081 | # $self->{layout}->render ($self->{ox}, $self->{oy}, $self->{style}); |
2065 | # DC::OpenGL::glEndList; |
2082 | # DC::OpenGL::glEndList; |
2066 | # } |
2083 | # } |
2067 | # |
2084 | # |
2068 | # DC::OpenGL::glCallList $self->{list}; |
2085 | # DC::OpenGL::glCallList $self->{list}; |
2069 | |
2086 | |
2070 | $self->{layout}->draw; |
2087 | $self->{layout}->draw; |
2071 | } |
2088 | } |
2072 | |
2089 | |
… | |
… | |
2221 | utf8::encode $text; $text = substr $text, 0, $idx; utf8::decode $text; |
2238 | utf8::encode $text; $text = substr $text, 0, $idx; utf8::decode $text; |
2222 | $self->{cursor} = length $text; |
2239 | $self->{cursor} = length $text; |
2223 | |
2240 | |
2224 | $self->_set_text ($self->{text}); |
2241 | $self->_set_text ($self->{text}); |
2225 | $self->update; |
2242 | $self->update; |
2226 | |
2243 | |
2227 | 1 |
2244 | 1 |
2228 | } |
2245 | } |
2229 | |
2246 | |
2230 | sub invoke_mouse_motion { |
2247 | sub invoke_mouse_motion { |
2231 | my ($self, $ev, $x, $y) = @_; |
2248 | my ($self, $ev, $x, $y) = @_; |
… | |
… | |
2516 | |
2533 | |
2517 | sub new { |
2534 | sub new { |
2518 | my $class = shift; |
2535 | my $class = shift; |
2519 | |
2536 | |
2520 | $class->SUPER::new ( |
2537 | $class->SUPER::new ( |
|
|
2538 | fontsize => 1, |
2521 | padding_x => 2, |
2539 | padding_x => 2, |
2522 | padding_y => 2, |
2540 | padding_y => 2, |
2523 | fg => [1, 1, 1], |
2541 | fg => [1, 1, 1], |
2524 | active_fg => [1, 1, 0], |
2542 | active_fg => [1, 1, 0], |
2525 | bg => [0, 0, 0, 0.2], |
2543 | bg => [0, 0, 0, 0.2], |
… | |
… | |
2531 | } |
2549 | } |
2532 | |
2550 | |
2533 | sub size_request { |
2551 | sub size_request { |
2534 | my ($self) = @_; |
2552 | my ($self) = @_; |
2535 | |
2553 | |
2536 | (6) x 2 |
2554 | ($self->{fontsize} * $::FONTSIZE) x 2 |
2537 | } |
2555 | } |
2538 | |
2556 | |
2539 | sub toggle { |
2557 | sub toggle { |
2540 | my ($self) = @_; |
2558 | my ($self) = @_; |
2541 | |
2559 | |
… | |
… | |
2579 | |
2597 | |
2580 | ############################################################################# |
2598 | ############################################################################# |
2581 | |
2599 | |
2582 | package DC::UI::Image; |
2600 | package DC::UI::Image; |
2583 | |
2601 | |
2584 | our @ISA = DC::UI::Base::; |
2602 | our @ISA = DC::UI::DrawBG::; |
2585 | |
2603 | |
2586 | use DC::OpenGL; |
2604 | use DC::OpenGL; |
2587 | |
2605 | |
2588 | our %texture_cache; |
2606 | our %texture_cache; |
2589 | |
2607 | |
… | |
… | |
2622 | my ($self, $cloning, $path) = @_; |
2640 | my ($self, $cloning, $path) = @_; |
2623 | |
2641 | |
2624 | $self->new (path => $path) |
2642 | $self->new (path => $path) |
2625 | } |
2643 | } |
2626 | |
2644 | |
|
|
2645 | sub set_texture { |
|
|
2646 | my ($self, $tex) = @_; |
|
|
2647 | |
|
|
2648 | $self->{tex} = $tex; |
|
|
2649 | $self->update; |
|
|
2650 | } |
|
|
2651 | |
2627 | sub size_request { |
2652 | sub size_request { |
2628 | my ($self) = @_; |
2653 | my ($self) = @_; |
2629 | |
2654 | |
2630 | (int $self->{tex}{w} * $self->{scale}, int $self->{tex}{h} * $self->{scale}) |
2655 | (int $self->{tex}{w} * $self->{scale}, int $self->{tex}{h} * $self->{scale}) |
2631 | } |
2656 | } |
2632 | |
2657 | |
2633 | sub _draw { |
2658 | sub _draw { |
2634 | my ($self) = @_; |
2659 | my ($self) = @_; |
|
|
2660 | |
|
|
2661 | $self->SUPER::_draw; |
2635 | |
2662 | |
2636 | my $tex = $self->{tex}; |
2663 | my $tex = $self->{tex}; |
2637 | |
2664 | |
2638 | my ($w, $h) = ($self->{w}, $self->{h}); |
2665 | my ($w, $h) = ($self->{w}, $self->{h}); |
2639 | |
2666 | |
… | |
… | |
2657 | package DC::UI::ImageButton; |
2684 | package DC::UI::ImageButton; |
2658 | |
2685 | |
2659 | our @ISA = DC::UI::Image::; |
2686 | our @ISA = DC::UI::Image::; |
2660 | |
2687 | |
2661 | use DC::OpenGL; |
2688 | use DC::OpenGL; |
2662 | |
|
|
2663 | my %textures; |
|
|
2664 | |
2689 | |
2665 | sub new { |
2690 | sub new { |
2666 | my $class = shift; |
2691 | my $class = shift; |
2667 | |
2692 | |
2668 | my $self = $class->SUPER::new ( |
2693 | my $self = $class->SUPER::new ( |
… | |
… | |
2839 | |
2864 | |
2840 | sub new { |
2865 | sub new { |
2841 | my ($class, %arg) = @_; |
2866 | my ($class, %arg) = @_; |
2842 | |
2867 | |
2843 | my $self = $class->SUPER::new ( |
2868 | my $self = $class->SUPER::new ( |
|
|
2869 | padding_x => 2, |
|
|
2870 | padding_y => 2, |
2844 | fg => [1, 1, 1], |
2871 | fg => [1, 1, 1], |
2845 | bg => [0, 0, 1, 0.2], |
2872 | bg => [0, 0, 1, 0.2], |
2846 | bar => [0.7, 0.5, 0.1, 0.8], |
2873 | bar => [0.7, 0.5, 0.1, 0.8], |
2847 | outline => [0.4, 0.3, 0], |
2874 | outline => [0.4, 0.3, 0], |
2848 | fontsize => 0.9, |
2875 | fontsize => 0.9, |
… | |
… | |
2888 | my ($self) = @_; |
2915 | my ($self) = @_; |
2889 | |
2916 | |
2890 | glEnable GL_BLEND; |
2917 | glEnable GL_BLEND; |
2891 | glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA; |
2918 | glBlendFunc GL_ONE, GL_ONE_MINUS_SRC_ALPHA; |
2892 | |
2919 | |
|
|
2920 | my $px = $self->{padding_x}; |
|
|
2921 | my $py = $self->{padding_y}; |
|
|
2922 | |
2893 | if ($self->{value} >= 0) { |
2923 | if ($self->{value} >= 0) { |
2894 | my $s = int 2 + ($self->{w} - 4) * $self->{value}; |
2924 | my $s = int $px + ($self->{w} - $px * 2) * $self->{value}; |
2895 | |
2925 | |
2896 | glColor_premultiply @{$self->{bar}}; |
2926 | glColor_premultiply @{$self->{bar}}; |
2897 | glRect 2, 2, $s, $self->{h} - 2; |
2927 | glRect $px, $py, $s, $self->{h} - $py; |
2898 | glColor_premultiply @{$self->{bg}}; |
2928 | glColor_premultiply @{$self->{bg}}; |
2899 | glRect $s, 2, $self->{w} - 2, $self->{h} - 2; |
2929 | glRect $s , $py, $self->{w} - $px, $self->{h} - $py; |
2900 | } |
2930 | } |
2901 | |
2931 | |
2902 | glColor_premultiply @{$self->{outline}}; |
2932 | glColor_premultiply @{$self->{outline}}; |
|
|
2933 | |
|
|
2934 | $px -= .5; |
|
|
2935 | $py -= .5; |
|
|
2936 | |
2903 | glRect_lineloop 1.5, 1.5, $self->{w} - 1.5, $self->{h} - 1.5; |
2937 | glRect_lineloop $px, $py, $self->{w} - $px, $self->{h} - $py; |
2904 | |
2938 | |
2905 | glDisable GL_BLEND; |
2939 | glDisable GL_BLEND; |
2906 | |
2940 | |
2907 | { |
2941 | { |
2908 | local $self->{bg}; # do not draw background |
2942 | local $self->{bg}; # do not draw background |
… | |
… | |
2917 | our @ISA = DC::UI::Progress::; |
2951 | our @ISA = DC::UI::Progress::; |
2918 | |
2952 | |
2919 | sub new { |
2953 | sub new { |
2920 | my ($class, %arg) = @_; |
2954 | my ($class, %arg) = @_; |
2921 | |
2955 | |
|
|
2956 | my $tt = exists $arg{tooltip} ? "$arg{tooltip}\n\n" : ""; |
|
|
2957 | |
2922 | my $self = $class->SUPER::new ( |
2958 | my $self = $class->SUPER::new ( |
|
|
2959 | %arg, |
2923 | tooltip => sub { |
2960 | tooltip => sub { |
2924 | my ($self) = @_; |
2961 | my ($self) = @_; |
2925 | |
2962 | |
2926 | sprintf "level %d\n%s points\n%s next level\n%s to go", |
2963 | sprintf "%slevel %d\n%s points\n%s next level\n%s to go, %d%% done", |
|
|
2964 | $tt, |
2927 | $self->{lvl}, |
2965 | $self->{lvl}, |
2928 | ::formsep ($self->{exp}), |
2966 | ::formsep ($self->{exp}), |
2929 | ::formsep ($self->{nxt}), |
2967 | ::formsep ($self->{nxt}), |
2930 | ::formsep ($self->{nxt} - $self->{exp}), |
2968 | ::formsep ($self->{nxt} - $self->{exp}), |
|
|
2969 | $self->_percent * 100, |
2931 | }, |
2970 | }, |
2932 | %arg |
|
|
2933 | ); |
2971 | ); |
2934 | |
2972 | |
2935 | $::CONN->{on_exp_update}{$self+0} = sub { $self->set_value ($self->{value}) } |
2973 | $::CONN->{on_exp_update}{$self+0} = sub { $self->set_value ($self->{value}) } |
2936 | if $::CONN; |
2974 | if $::CONN; |
2937 | |
2975 | |
… | |
… | |
2945 | if $::CONN; |
2983 | if $::CONN; |
2946 | |
2984 | |
2947 | $self->SUPER::DESTROY; |
2985 | $self->SUPER::DESTROY; |
2948 | } |
2986 | } |
2949 | |
2987 | |
|
|
2988 | sub _percent { |
|
|
2989 | my ($self) = @_; |
|
|
2990 | |
|
|
2991 | my $table = $::CONN && $::CONN->{exp_table} |
|
|
2992 | or return -1; |
|
|
2993 | |
|
|
2994 | my $l0 = $table->[$self->{lvl} - 1]; |
|
|
2995 | my $l1 = $table->[$self->{lvl}]; |
|
|
2996 | |
|
|
2997 | $self->{nxt} = $l1; |
|
|
2998 | |
|
|
2999 | ($self->{exp} - $l0) / ($l1 - $l0) |
|
|
3000 | } |
|
|
3001 | |
2950 | sub set_value { |
3002 | sub set_value { |
2951 | my ($self, $lvl, $exp) = @_; |
3003 | my ($self, $lvl, $exp) = @_; |
2952 | |
3004 | |
2953 | $self->{lvl} = $lvl; |
3005 | $self->{lvl} = $lvl; |
2954 | $self->{exp} = $exp; |
3006 | $self->{exp} = $exp; |
2955 | |
3007 | |
2956 | my $v = -1; |
|
|
2957 | |
|
|
2958 | if ($::CONN && (my $table = $::CONN->{exp_table})) { |
|
|
2959 | my $l0 = $table->[$lvl - 1]; |
|
|
2960 | my $l1 = $table->[$lvl]; |
|
|
2961 | |
|
|
2962 | $self->{nxt} = $l1; |
|
|
2963 | |
|
|
2964 | $v = ($exp - $l0) / ($l1 - $l0); |
|
|
2965 | } |
|
|
2966 | |
|
|
2967 | $self->SUPER::set_value ($v); |
3008 | $self->SUPER::set_value ($self->_percent); |
2968 | } |
3009 | } |
2969 | |
3010 | |
2970 | ############################################################################# |
3011 | ############################################################################# |
2971 | |
3012 | |
2972 | package DC::UI::Gauge; |
3013 | package DC::UI::Gauge; |
… | |
… | |
3016 | |
3057 | |
3017 | ############################################################################# |
3058 | ############################################################################# |
3018 | |
3059 | |
3019 | package DC::UI::Slider; |
3060 | package DC::UI::Slider; |
3020 | |
3061 | |
3021 | use strict; |
3062 | use common::sense; |
3022 | |
3063 | |
3023 | use DC::OpenGL; |
3064 | use DC::OpenGL; |
3024 | |
3065 | |
3025 | our @ISA = DC::UI::DrawBG::; |
3066 | our @ISA = DC::UI::DrawBG::; |
3026 | |
3067 | |
… | |
… | |
3098 | my ($self, $ev, $x, $y) = @_; |
3139 | my ($self, $ev, $x, $y) = @_; |
3099 | |
3140 | |
3100 | $self->SUPER::invoke_button_down ($ev, $x, $y); |
3141 | $self->SUPER::invoke_button_down ($ev, $x, $y); |
3101 | |
3142 | |
3102 | $self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x]; |
3143 | $self->{click} = [$self->{range}[0], $self->{vertical} ? $y : $x]; |
3103 | |
3144 | |
3104 | $self->invoke_mouse_motion ($ev, $x, $y); |
3145 | $self->invoke_mouse_motion ($ev, $x, $y); |
3105 | |
3146 | |
3106 | 1 |
3147 | 1 |
3107 | } |
3148 | } |
3108 | |
3149 | |
… | |
… | |
3112 | if ($GRAB == $self) { |
3153 | if ($GRAB == $self) { |
3113 | my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w}); |
3154 | my ($x, $w) = $self->{vertical} ? ($y, $self->{h}) : ($x, $self->{w}); |
3114 | |
3155 | |
3115 | my (undef, $lo, $hi, $page) = @{$self->{range}}; |
3156 | my (undef, $lo, $hi, $page) = @{$self->{range}}; |
3116 | |
3157 | |
3117 | $x = ($x - $self->{click}[1]) / ($w * $self->{scale}); |
3158 | $x = ($x - $self->{click}[1]) / ($w * $self->{scale} || 1e999); |
3118 | |
3159 | |
3119 | $self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo)); |
3160 | $self->set_value ($self->{click}[0] + $x * ($hi - $page - $lo)); |
3120 | } else { |
3161 | } else { |
3121 | return 0; |
3162 | return 0; |
3122 | } |
3163 | } |
… | |
… | |
3168 | |
3209 | |
3169 | glScale $self->{w}, $self->{h}; |
3210 | glScale $self->{w}, $self->{h}; |
3170 | |
3211 | |
3171 | if ($self->{vertical}) { |
3212 | if ($self->{vertical}) { |
3172 | # draw a vertical slider like a rotated horizontal slider |
3213 | # draw a vertical slider like a rotated horizontal slider |
3173 | |
3214 | |
3174 | glTranslate 1, 0, 0; |
3215 | glTranslate 1, 0, 0; |
3175 | glRotate 90, 0, 0, 1; |
3216 | glRotate 90, 0, 0, 1; |
3176 | } |
3217 | } |
3177 | |
3218 | |
3178 | my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg}; |
3219 | my $fg = $FOCUS == $self ? $self->{active_fg} : $self->{fg}; |
… | |
… | |
3246 | fontsize => 1, |
3287 | fontsize => 1, |
3247 | can_events => 1, |
3288 | can_events => 1, |
3248 | indent => 0, |
3289 | indent => 0, |
3249 | #font => default_font |
3290 | #font => default_font |
3250 | @_, |
3291 | @_, |
3251 | |
3292 | |
3252 | layout => (new DC::Layout), |
3293 | layout => (new DC::Layout), |
3253 | par => [], |
|
|
3254 | max_par => 0, |
3294 | max_par => 0, |
3255 | height => 0, |
3295 | height => 0, |
3256 | children => [ |
3296 | children => [ |
3257 | (new DC::UI::Empty expand => 1), |
3297 | (new DC::UI::Empty expand => 1), |
3258 | (new DC::UI::Slider vertical => 1), |
3298 | (new DC::UI::Slider vertical => 1), |
3259 | ], |
3299 | ], |
3260 | ); |
3300 | ); |
3261 | |
3301 | |
3262 | $self->{children}[1]->connect (changed => sub { $self->update }); |
3302 | $self->{children}[1]->connect (changed => sub { $self->update }); |
|
|
3303 | |
|
|
3304 | $self->add_paragraph (@{ delete $self->{par} }) if @{ $self->{par} }; |
3263 | |
3305 | |
3264 | $self |
3306 | $self |
3265 | } |
3307 | } |
3266 | |
3308 | |
3267 | sub set_fontsize { |
3309 | sub set_fontsize { |
… | |
… | |
3531 | my ($self, $x, $y) = @_; |
3573 | my ($self, $x, $y) = @_; |
3532 | |
3574 | |
3533 | $self->{moveto} = [$self->{x}, $self->{y}, $x, $y]; |
3575 | $self->{moveto} = [$self->{x}, $self->{y}, $x, $y]; |
3534 | $self->{speed} = 0.001; |
3576 | $self->{speed} = 0.001; |
3535 | $self->{time} = 1; |
3577 | $self->{time} = 1; |
3536 | |
3578 | |
3537 | ::animation_start $self; |
3579 | ::animation_start $self; |
3538 | } |
3580 | } |
3539 | |
3581 | |
3540 | sub animate { |
3582 | sub animate { |
3541 | my ($self, $interval) = @_; |
3583 | my ($self, $interval) = @_; |
… | |
… | |
3545 | $self->{time} = 0; |
3587 | $self->{time} = 0; |
3546 | ::animation_stop $self; |
3588 | ::animation_stop $self; |
3547 | } |
3589 | } |
3548 | |
3590 | |
3549 | my ($x0, $y0, $x1, $y1) = @{$self->{moveto}}; |
3591 | my ($x0, $y0, $x1, $y1) = @{$self->{moveto}}; |
3550 | |
3592 | |
3551 | $self->{x} = $x0 * $self->{time} + $x1 * (1 - $self->{time}); |
3593 | $self->{x} = $x0 * $self->{time} + $x1 * (1 - $self->{time}); |
3552 | $self->{y} = $y0 * $self->{time} + $y1 * (1 - $self->{time}); |
3594 | $self->{y} = $y0 * $self->{time} + $y1 * (1 - $self->{time}); |
3553 | } |
3595 | } |
3554 | |
3596 | |
3555 | sub _draw { |
3597 | sub _draw { |
… | |
… | |
3600 | @_, |
3642 | @_, |
3601 | can_events => 0, |
3643 | can_events => 0, |
3602 | ) |
3644 | ) |
3603 | } |
3645 | } |
3604 | |
3646 | |
|
|
3647 | # expand, as good as possible |
|
|
3648 | sub _expand_doclets { |
|
|
3649 | my ($tip) = @_; |
|
|
3650 | |
|
|
3651 | $tip =~ s{#\(([^)]+)\)}{ |
|
|
3652 | if ($::CONN) { |
|
|
3653 | exists $::CONN->{doclet}{$1} |
|
|
3654 | ? $::CONN->{doclet}{$1} |
|
|
3655 | : "(waiting for server to show full text)" |
|
|
3656 | } else { |
|
|
3657 | "(unable to show full text without server connection)" |
|
|
3658 | } |
|
|
3659 | }ge; |
|
|
3660 | |
|
|
3661 | $tip =~ s/^\n+//; |
|
|
3662 | $tip =~ s/\n+$//; |
|
|
3663 | |
|
|
3664 | $tip |
|
|
3665 | } |
|
|
3666 | |
|
|
3667 | # expands a tooltip, potentially multiple times remotely |
|
|
3668 | # and returns a guard. clals the clalback each time the text changes. |
|
|
3669 | sub expand_tooltip { |
|
|
3670 | my ($tip, $cb) = @_; |
|
|
3671 | |
|
|
3672 | # first expand #name tooltips from local pod |
|
|
3673 | $tip = DC::Pod::section_label tooltip => $1 |
|
|
3674 | if $tip =~ /^#([^(].*)$/; |
|
|
3675 | |
|
|
3676 | my $active; # true if any remote requests outstanding |
|
|
3677 | |
|
|
3678 | if ($::CONN && $::CONN->{addme_success}) { |
|
|
3679 | # now find all doclet references |
|
|
3680 | for my $doclet ($tip =~ /#\(([^)]+)\)/g) { |
|
|
3681 | unless (exists $::CONN->{doclet}{$doclet}) { |
|
|
3682 | # need to ask the server |
|
|
3683 | # we don't try to avoid duplicate requests |
|
|
3684 | |
|
|
3685 | $active = 1; |
|
|
3686 | $::CONN->send_exti_req (doclet => (split /\//, $doclet, 2), sub { |
|
|
3687 | $::CONN->{doclet}{$doclet} = DC::sanitise_cfxml $_[0]; |
|
|
3688 | $cb->(_expand_doclets $tip) if $active; |
|
|
3689 | }); |
|
|
3690 | } |
|
|
3691 | } |
|
|
3692 | } |
|
|
3693 | |
|
|
3694 | $cb->(_expand_doclets $tip); |
|
|
3695 | |
|
|
3696 | $active and Guard::guard { undef $active } |
|
|
3697 | } |
|
|
3698 | |
3605 | sub set_tooltip_from { |
3699 | sub set_tooltip_from { |
3606 | my ($self, $widget) = @_; |
3700 | my ($self, $widget) = @_; |
3607 | |
3701 | |
3608 | my $tip = $widget->{tooltip}; |
3702 | my $tip = $widget->{tooltip}; |
3609 | $tip = $tip->($widget) if "CODE" eq ref $tip; |
3703 | $tip = $tip->($widget) if "CODE" eq ref $tip; |
3610 | |
|
|
3611 | $tip = DC::Pod::section_label tooltip => $1 |
|
|
3612 | if $tip =~ /^#(.*)$/; |
|
|
3613 | |
|
|
3614 | if ($ENV{CFPLUS_DEBUG} & 2) { |
|
|
3615 | $tip .= "\n\n" . (ref $widget) . "\n" |
|
|
3616 | . "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n" |
|
|
3617 | . "req $widget->{req_w} $widget->{req_h}\n" |
|
|
3618 | . "visible $widget->{visible}"; |
|
|
3619 | } |
|
|
3620 | |
|
|
3621 | $tip =~ s/^\n+//; |
|
|
3622 | $tip =~ s/\n+$//; |
|
|
3623 | |
3704 | |
3624 | $self->add (new DC::UI::Label |
3705 | $self->add (new DC::UI::Label |
3625 | fg => $DC::THEME{tooltip_fg}, |
3706 | fg => $DC::THEME{tooltip_fg}, |
3626 | markup => $tip, |
|
|
3627 | max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH, |
3707 | max_w => ($widget->{tooltip_width} || 0.25) * $::WIDTH, |
3628 | align => 0, |
3708 | align => 0, |
3629 | fontsize => 0.8, |
3709 | fontsize => 0.8, |
3630 | style => $DC::THEME{tooltip_style}, # FLAG_INVERSE |
3710 | style => $DC::THEME{tooltip_style}, # FLAG_INVERSE |
3631 | ellipsise => 0, |
3711 | ellipsise => 0, |
3632 | font => ($widget->{tooltip_font} || $::FONT_PROP), |
3712 | font => ($widget->{tooltip_font} || $::FONT_PROP), |
3633 | ); |
3713 | ); |
|
|
3714 | |
|
|
3715 | $self->{tooltip_expand} = expand_tooltip $tip, sub { |
|
|
3716 | my ($tip) = @_; |
|
|
3717 | |
|
|
3718 | if ($ENV{CFPLUS_DEBUG} & 2) { |
|
|
3719 | $tip .= "\n\n" . (ref $widget) . "\n" |
|
|
3720 | . "$widget->{x} $widget->{y} $widget->{w} $widget->{h}\n" |
|
|
3721 | . "req $widget->{req_w} $widget->{req_h}\n" |
|
|
3722 | . "visible $widget->{visible}"; |
|
|
3723 | } |
|
|
3724 | |
|
|
3725 | $self->{children}[0]->set_markup ($tip); |
|
|
3726 | }; |
3634 | } |
3727 | } |
3635 | |
3728 | |
3636 | sub size_request { |
3729 | sub size_request { |
3637 | my ($self) = @_; |
3730 | my ($self) = @_; |
3638 | |
3731 | |
… | |
… | |
3674 | |
3767 | |
3675 | my ($w, $h) = @$self{qw(w h)}; |
3768 | my ($w, $h) = @$self{qw(w h)}; |
3676 | |
3769 | |
3677 | glColor @{ $DC::THEME{tooltip_bg} }; |
3770 | glColor @{ $DC::THEME{tooltip_bg} }; |
3678 | glRect 0, 0, $w, $h; |
3771 | glRect 0, 0, $w, $h; |
3679 | |
3772 | |
3680 | glColor @{ $DC::THEME{tooltip_border} }; |
3773 | glColor @{ $DC::THEME{tooltip_border} }; |
3681 | glRect_lineloop .5, .5, $w + .5, $h + .5; |
3774 | glRect_lineloop .5, .5, $w + .5, $h + .5; |
3682 | |
3775 | |
3683 | glTranslate 2, 2; |
3776 | glTranslate 2, 2; |
3684 | |
3777 | |
3685 | $self->SUPER::_draw; |
3778 | $self->SUPER::_draw; |
3686 | } |
3779 | } |
3687 | |
3780 | |
… | |
… | |
3702 | aspect => 1, |
3795 | aspect => 1, |
3703 | can_events => 0, |
3796 | can_events => 0, |
3704 | @_, |
3797 | @_, |
3705 | ); |
3798 | ); |
3706 | |
3799 | |
3707 | if ($self->{anim} && $self->{animspeed}) { |
|
|
3708 | DC::weaken (my $widget = $self); |
|
|
3709 | |
|
|
3710 | $self->{animspeed} = List::Util::max 0.05, $self->{animspeed}; |
|
|
3711 | $self->{timer} = EV::periodic_ns 0, $self->{animspeed}, undef, sub { |
|
|
3712 | return unless $::CONN; |
|
|
3713 | |
|
|
3714 | my $w = $widget |
|
|
3715 | or return; |
|
|
3716 | |
|
|
3717 | ++$w->{frame}; |
|
|
3718 | $w->update_face; |
|
|
3719 | |
|
|
3720 | # somehow, $widget can go away |
|
|
3721 | $w->update; |
|
|
3722 | $w->update_timer; |
|
|
3723 | }; |
|
|
3724 | |
|
|
3725 | $self->update_face; |
|
|
3726 | $self->update_timer; |
3800 | $self->update_anim; |
3727 | } |
3801 | |
3728 | |
|
|
3729 | $self |
3802 | $self |
3730 | } |
3803 | } |
3731 | |
3804 | |
3732 | sub update_timer { |
3805 | sub update_timer { |
3733 | my ($self) = @_; |
3806 | my ($self) = @_; |
… | |
… | |
3755 | $tex->upload (sub { $self->reconfigure }); |
3828 | $tex->upload (sub { $self->reconfigure }); |
3756 | } |
3829 | } |
3757 | } |
3830 | } |
3758 | } |
3831 | } |
3759 | } |
3832 | } |
|
|
3833 | } |
|
|
3834 | } |
|
|
3835 | |
|
|
3836 | sub update_anim { |
|
|
3837 | my ($self) = @_; |
|
|
3838 | |
|
|
3839 | if ($self->{anim} && $self->{animspeed}) { |
|
|
3840 | DC::weaken (my $widget = $self); |
|
|
3841 | |
|
|
3842 | $self->{animspeed} = List::Util::max 0.05, $self->{animspeed}; |
|
|
3843 | $self->{timer} = EV::periodic_ns 0, $self->{animspeed}, undef, sub { |
|
|
3844 | return unless $::CONN; |
|
|
3845 | |
|
|
3846 | my $w = $widget |
|
|
3847 | or return; |
|
|
3848 | |
|
|
3849 | ++$w->{frame}; |
|
|
3850 | $w->update_face; |
|
|
3851 | |
|
|
3852 | # somehow, $widget can go away |
|
|
3853 | $w->update; |
|
|
3854 | $w->update_timer; |
|
|
3855 | }; |
|
|
3856 | |
|
|
3857 | $self->update_face; |
|
|
3858 | $self->update_timer; |
|
|
3859 | } else { |
|
|
3860 | delete $self->{timer}; |
3760 | } |
3861 | } |
3761 | } |
3862 | } |
3762 | |
3863 | |
3763 | sub size_request { |
3864 | sub size_request { |
3764 | my ($self) = @_; |
3865 | my ($self) = @_; |
… | |
… | |
3786 | return unless $self->{visible}; |
3887 | return unless $self->{visible}; |
3787 | |
3888 | |
3788 | $self->SUPER::update; |
3889 | $self->SUPER::update; |
3789 | } |
3890 | } |
3790 | |
3891 | |
|
|
3892 | sub set_face { |
|
|
3893 | my ($self, $face) = @_; |
|
|
3894 | |
|
|
3895 | $self->{face} = $face; |
|
|
3896 | $self->reconfigure; |
|
|
3897 | } |
|
|
3898 | |
|
|
3899 | sub set_anim { |
|
|
3900 | my ($self, $anim) = @_; |
|
|
3901 | |
|
|
3902 | $self->{anim} = $anim; |
|
|
3903 | $self->update_anim; |
|
|
3904 | } |
|
|
3905 | |
|
|
3906 | sub set_animspeed { |
|
|
3907 | my ($self, $animspeed) = @_; |
|
|
3908 | |
|
|
3909 | $self->{animspeed} = $animspeed; |
|
|
3910 | $self->update_anim; |
|
|
3911 | } |
|
|
3912 | |
3791 | sub invoke_visibility_change { |
3913 | sub invoke_visibility_change { |
3792 | my ($self) = @_; |
3914 | my ($self) = @_; |
3793 | |
3915 | |
3794 | $self->update_timer; |
3916 | $self->update_timer; |
3795 | |
3917 | |
… | |
… | |
3891 | # maybe save $GRAB? must be careful about events... |
4013 | # maybe save $GRAB? must be careful about events... |
3892 | $GRAB = $self; |
4014 | $GRAB = $self; |
3893 | $self->{button} = $ev->{button}; |
4015 | $self->{button} = $ev->{button}; |
3894 | |
4016 | |
3895 | $self->show; |
4017 | $self->show; |
3896 | $self->move_abs ($ev->{x} - $self->{w} * 0.5, $ev->{y} - $self->{h} * 0.5); |
4018 | |
|
|
4019 | my $x = $ev->{x}; |
|
|
4020 | my $y = $ev->{y}; |
|
|
4021 | |
|
|
4022 | $self->{root}->on_post_alloc ($self => sub { |
|
|
4023 | $self->move_abs ($x - $self->{w} * 0.25, $y - $self->{border} * $::FONTSIZE * .5); |
|
|
4024 | }); |
|
|
4025 | |
|
|
4026 | 1 # so it can be used inside event handlers |
3897 | } |
4027 | } |
3898 | |
4028 | |
3899 | sub invoke_mouse_motion { |
4029 | sub invoke_mouse_motion { |
3900 | my ($self, $ev, $x, $y) = @_; |
4030 | my ($self, $ev, $x, $y) = @_; |
3901 | |
4031 | |
… | |
… | |
3933 | |
4063 | |
3934 | my $self = $class->SUPER::new ( |
4064 | my $self = $class->SUPER::new ( |
3935 | @_, |
4065 | @_, |
3936 | ); |
4066 | ); |
3937 | |
4067 | |
3938 | $self->{current} = $self->{children}[0] |
4068 | $self->set_current_page (0); |
3939 | if @{ $self->{children} }; |
|
|
3940 | |
4069 | |
3941 | $self |
4070 | $self |
3942 | } |
4071 | } |
3943 | |
4072 | |
3944 | sub add { |
4073 | sub add { |
3945 | my ($self, @widgets) = @_; |
4074 | my ($self, @widgets) = @_; |
3946 | |
4075 | |
3947 | $self->SUPER::add (@widgets); |
4076 | $self->SUPER::add (@widgets); |
3948 | |
4077 | |
3949 | $self->{current} = $self->{children}[0] |
4078 | $self->set_current_page (0) |
3950 | if @{ $self->{children} }; |
4079 | if @widgets == @{ $self->{children} }; |
3951 | } |
4080 | } |
3952 | |
4081 | |
3953 | sub get_current_page { |
4082 | sub get_current_page { |
3954 | my ($self) = @_; |
4083 | my ($self) = @_; |
3955 | |
4084 | |
… | |
… | |
3961 | |
4090 | |
3962 | my $widget = ref $page_or_widget |
4091 | my $widget = ref $page_or_widget |
3963 | ? $page_or_widget |
4092 | ? $page_or_widget |
3964 | : $self->{children}[$page_or_widget]; |
4093 | : $self->{children}[$page_or_widget]; |
3965 | |
4094 | |
|
|
4095 | $self->{current}->set_invisible if $self->{current} && $self->{visible}; |
|
|
4096 | |
3966 | $self->{current} = $widget; |
4097 | if (($self->{current} = $widget)) { |
|
|
4098 | $self->{current}->set_visible if $self->{current} && $self->{visible}; |
3967 | $self->{current}->configure (0, 0, $self->{w}, $self->{h}); |
4099 | $self->{current}->configure (0, 0, $self->{w}, $self->{h}); |
3968 | |
4100 | |
3969 | $self->emit (page_changed => $self->{current}); |
4101 | $self->emit (page_changed => $self->{current}); |
|
|
4102 | } |
3970 | |
4103 | |
3971 | $self->realloc; |
4104 | $self->realloc; |
3972 | } |
4105 | } |
3973 | |
4106 | |
3974 | sub visible_children { |
4107 | sub visible_children { |
3975 | $_[0]{current} |
4108 | $_[0]{current} || () |
3976 | } |
4109 | } |
3977 | |
4110 | |
3978 | sub size_request { |
4111 | sub size_request { |
3979 | my ($self) = @_; |
4112 | my ($self) = @_; |
3980 | |
4113 | |
|
|
4114 | $self->{current} |
3981 | $self->{current}->size_request |
4115 | ? $self->{current}->size_request |
|
|
4116 | : (0, 0) |
3982 | } |
4117 | } |
3983 | |
4118 | |
3984 | sub invoke_size_allocate { |
4119 | sub invoke_size_allocate { |
3985 | my ($self, $w, $h) = @_; |
4120 | my ($self, $w, $h) = @_; |
3986 | |
4121 | |
3987 | $self->{current}->configure (0, 0, $w, $h); |
4122 | $self->{current}->configure (0, 0, $w, $h) |
|
|
4123 | if $self->{current}; |
3988 | |
4124 | |
3989 | 1 |
4125 | 1 |
3990 | } |
4126 | } |
3991 | |
4127 | |
3992 | sub _draw { |
4128 | sub _draw { |
3993 | my ($self) = @_; |
4129 | my ($self) = @_; |
3994 | |
4130 | |
3995 | $self->{current}->draw; |
4131 | $self->{current}->draw |
|
|
4132 | if $self->{current}; |
3996 | } |
4133 | } |
3997 | |
4134 | |
3998 | ############################################################################# |
4135 | ############################################################################# |
3999 | |
4136 | |
4000 | package DC::UI::Notebook; |
4137 | package DC::UI::Notebook; |
… | |
… | |
4210 | $self |
4347 | $self |
4211 | } |
4348 | } |
4212 | |
4349 | |
4213 | sub reorder { |
4350 | sub reorder { |
4214 | my ($self) = @_; |
4351 | my ($self) = @_; |
4215 | my $NOW = Time::HiRes::time; |
4352 | my $NOW = AE::time; |
4216 | |
4353 | |
4217 | # freeze display when hovering over any label |
4354 | # freeze display when hovering over any label |
4218 | return if $DC::UI::TOOLTIP->{owner} |
4355 | return if $DC::UI::TOOLTIP->{owner} |
4219 | && grep $DC::UI::TOOLTIP->{owner} == $_->{label}, |
4356 | && grep $DC::UI::TOOLTIP->{owner} == $_->{label}, |
4220 | values %{ $self->{item} }; |
4357 | values %{ $self->{item} }; |
… | |
… | |
4270 | $label->{fg}[3] = $item->{fg}[3] || 1; |
4407 | $label->{fg}[3] = $item->{fg}[3] || 1; |
4271 | } |
4408 | } |
4272 | |
4409 | |
4273 | push @widgets, $label; |
4410 | push @widgets, $label; |
4274 | } |
4411 | } |
|
|
4412 | |
|
|
4413 | my $hash = join ",", @widgets; |
|
|
4414 | return if $hash eq $self->{last_widget_hash}; |
|
|
4415 | $self->{last_widget_hash} = $hash; |
4275 | |
4416 | |
4276 | $self->clear; |
4417 | $self->clear; |
4277 | $self->SUPER::add (reverse @widgets); |
4418 | $self->SUPER::add (reverse @widgets); |
4278 | } |
4419 | } |
4279 | |
4420 | |
… | |
… | |
4315 | $ROOT->on_refresh (reorder => sub { |
4456 | $ROOT->on_refresh (reorder => sub { |
4316 | $self->reorder; |
4457 | $self->reorder; |
4317 | }); |
4458 | }); |
4318 | } |
4459 | } |
4319 | |
4460 | |
|
|
4461 | sub clr_group { |
|
|
4462 | my ($self, $group) = @_; |
|
|
4463 | |
|
|
4464 | if (delete $self->{item}{$group}) { |
|
|
4465 | $ROOT->on_refresh (reorder => sub { |
|
|
4466 | $self->reorder; |
|
|
4467 | }); |
|
|
4468 | } |
|
|
4469 | } |
|
|
4470 | |
4320 | sub reconfigure { |
4471 | sub reconfigure { |
4321 | my ($self) = @_; |
4472 | my ($self) = @_; |
4322 | |
4473 | |
4323 | delete $_->{label} |
4474 | delete $_->{label} |
4324 | for values %{ $self->{item} || {} }; |
4475 | for values %{ $self->{item} || {} }; |
… | |
… | |
4478 | while () { |
4629 | while () { |
4479 | @queue or last outer; |
4630 | @queue or last outer; |
4480 | |
4631 | |
4481 | $widget = pop @{ $queue[-1] || [] } |
4632 | $widget = pop @{ $queue[-1] || [] } |
4482 | and last; |
4633 | and last; |
4483 | |
4634 | |
4484 | pop @queue; |
4635 | pop @queue; |
4485 | } |
4636 | } |
4486 | |
4637 | |
4487 | delete $queue{$widget+0}; |
4638 | delete $queue{$widget+0}; |
4488 | |
4639 | |
… | |
… | |
4584 | |
4735 | |
4585 | $ROOT = new DC::UI::Root; |
4736 | $ROOT = new DC::UI::Root; |
4586 | $TOOLTIP = new DC::UI::Tooltip z => 900; |
4737 | $TOOLTIP = new DC::UI::Tooltip z => 900; |
4587 | |
4738 | |
4588 | 1 |
4739 | 1 |
4589 | |
|
|