ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC/MapWidget.pm
(Generate patch)

Comparing deliantra/Deliantra-Client/DC/MapWidget.pm (file contents):
Revision 1.162 by root, Sat Apr 3 02:58:25 2010 UTC vs.
Revision 1.171 by root, Mon Nov 26 13:14:43 2012 UTC

1package DC::MapWidget; 1package DC::MapWidget;
2 2
3use common::sense; 3use common::sense;
4 4
5use List::Util qw(min max); 5use List::Util qw(min max);
6
7use AnyEvent ();
6 8
7use DC; 9use DC;
8use DC::OpenGL; 10use DC::OpenGL;
9use DC::UI; 11use DC::UI;
10use DC::Macro; 12use DC::Macro;
29 tilesize => 32, 31 tilesize => 32,
30 @_ 32 @_
31 ); 33 );
32 34
33 $self 35 $self
34}
35
36sub add_command {
37 my ($self, $command, $tooltip, $widget, $cb) = @_;
38
39 (my $data = $command) =~ s/\\//g;
40
41 $tooltip =~ s/^\s+//;
42 $tooltip = "<big>$data</big>\n\n$tooltip";
43 $tooltip =~ s/\s+$//;
44
45 $::COMPLETER->{command}{$command} = [$data, $tooltip, $widget, $cb, ++$self->{command_id}];
46}
47
48sub clr_commands {
49 my ($self) = @_;
50
51 %{$::COMPLETER->{command}} = ();
52
53 $::COMPLETER->hide
54 if $::COMPLETER;
55} 36}
56 37
57sub server_login { 38sub server_login {
58 my ($server) = @_; 39 my ($server) = @_;
59 40
431sub movement_update { 412sub movement_update {
432 my ($self) = @_; 413 my ($self) = @_;
433 414
434 if ($::CFG->{smooth_movement}) { 415 if ($::CFG->{smooth_movement}) {
435 if ($self->{sdx} || $self->{sdy}) { 416 if ($self->{sdx} || $self->{sdy}) {
436 my $diff = EV::time - ($self->{last_update} || $::LAST_REFRESH); 417 my $diff = AE::time - ($self->{last_update} || $::LAST_REFRESH);
437 my $spd = $::CONN->{stat}{DC::Protocol::CS_STAT_SPEED}; 418 my $spd = $::CONN->{stat}{DC::Protocol::CS_STAT_SPEED};
438 419
439 # the minimum time for a single tile movement 420 # the minimum time for a single tile movement
440 my $mintime = DC::Protocol::TICK * DC::ceil 1 / ($spd * DC::Protocol::TICK || 1); 421 my $mintime = DC::Protocol::TICK * DC::ceil 1 / ($spd * DC::Protocol::TICK || 1);
441 422
462 } 443 }
463 } else { 444 } else {
464 $self->{sdx} = $self->{sdy} = 0; 445 $self->{sdx} = $self->{sdy} = 0;
465 } 446 }
466 447
467 $self->{last_update} = EV::time; 448 $self->{last_update} = AE::time;
468} 449}
469 450
470sub refresh_hook { 451sub refresh_hook {
471 my ($self) = @_; 452 my ($self) = @_;
472 453
514 glTranslate $sx0, $sy0; 495 glTranslate $sx0, $sy0;
515 glScale $::CFG->{map_scale}, $::CFG->{map_scale}; 496 glScale $::CFG->{map_scale}, $::CFG->{map_scale};
516 glTranslate DC::ceil $self->{sdx}, DC::ceil $self->{sdy}; 497 glTranslate DC::ceil $self->{sdx}, DC::ceil $self->{sdy};
517 498
518 $::MAP->draw ($dx, $dy, $sw, $sh, 499 $::MAP->draw ($dx, $dy, $sw, $sh,
519 $self->{tilesize}, 500 ($self->{tilesize}) x 2,
520 $::CONN->{player}{tag}, 501 $::CONN->{player}{tag},
521 -$self->{sdx}, -$self->{sdy}); 502 -$self->{sdx}, -$self->{sdy});
522 503
523 glScale $self->{tilesize}, $self->{tilesize}; 504 glScale $self->{tilesize}, $self->{tilesize};
524 505
611 592
612use common::sense; 593use common::sense;
613 594
614our @ISA = DC::UI::Base::; 595our @ISA = DC::UI::Base::;
615 596
616use Time::HiRes qw(time);
617use DC::OpenGL; 597use DC::OpenGL;
618 598
619sub size_request { 599sub size_request {
620 ($::HEIGHT * 0.2, $::HEIGHT * 0.2) 600 ($::HEIGHT * 0.2, $::HEIGHT * 0.2)
621} 601}
622 602
623sub refresh_hook { 603sub refresh_hook {
624 my ($self) = @_; 604 my ($self) = @_;
625 605
626 if ($::MAP && $self->{texture_atime} < time) { 606 if ($::MAP && $self->{texture_atime} < AE::now) {
627 my ($w, $h) = @$self{qw(w h)}; 607 my ($w, $h) = @$self{qw(w h)};
628 608
629 return unless $w && $h; 609 return unless $w && $h;
630 610
631 my $sw = int $::WIDTH / ($::MAPWIDGET->{tilesize} * $::CFG->{map_scale}) + 0.99; 611 my $sw = int $::WIDTH / ($::MAPWIDGET->{tilesize} * $::CFG->{map_scale}) + 0.99;
646 $self->{sh} = $sh; 626 $self->{sh} = $sh;
647 627
648 $self->{x0} = $x0; 628 $self->{x0} = $x0;
649 $self->{y0} = $y0; 629 $self->{y0} = $y0;
650 630
651 $self->{texture_atime} = time + 1/3; 631 $self->{texture_atime} = AE::now + 1/2;
652 632
653 $self->{texture} = 633 $self->{texture} =
654 new DC::Texture 634 new DC::Texture
655 w => $w, 635 w => $w,
656 h => $h, 636 h => $h,
721 701
722sub new { 702sub new {
723 my $class = shift; 703 my $class = shift;
724 704
725 my $self = $class->SUPER::new ( 705 my $self = $class->SUPER::new (
706 min_w => $::WIDTH * 0.25, # workaround for layout problems #d#
726 bg => [0, 0, 0, 0.8], 707 bg => [0, 0, 0, 0.8],
727 @_, 708 @_,
728 ); 709 );
729 710
730 $self->add ($self->{vbox} = new DC::UI::VBox); 711 $self->add ($self->{vbox} = new DC::UI::VBox);
817 ); 798 );
818 799
819 $self 800 $self
820} 801}
821 802
803sub reset {
804 my ($self) = @_;
805
806 $self->hide;
807 delete $self->{command_lists};
808 delete $self->{command_list};
809}
810
822sub set_prefix { 811sub set_prefix {
823 my ($self, $prefix) = @_; 812 my ($self, $prefix) = @_;
824 813
825 $self->{entry}->set_text ($prefix); 814 $self->{entry}->set_text ($prefix);
826 $self->show; 815 $self->show;
858} 847}
859 848
860sub update_labels { 849sub update_labels {
861 my ($self) = @_; 850 my ($self) = @_;
862 851
852 use sort qw(stable);
853
863 my $text = $self->{entry}->get_text; 854 my $text = $self->{entry}->get_text;
864 855
865 length $text 856 length $text
866 or return $self->hide; 857 or return $self->hide;
867 858
859 return unless $::CONN;
860
861 # regenerate spell list if necessary
862 $self->{command_list}{spells} ||= [
863 map { ("cast $_->{name}", "invoke $_->{name}") }
864 values %{ $::CONN->{spell} }
865 ];
866
868 if ($text ne $self->{last_search}) { 867 if ($text ne $self->{last_search}) {
869 my @match; 868 my @match;
870 869
871 if ($text =~ /^(.*?)\s+$/) { 870 if ($text =~ /^(.*?)\s+$/) {
872 my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/; 871 my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/;
873 @match = ([[$cmd,'(appended whitespace suppresses completion)'],$text]); 872 @match = ([[$cmd,' (appended whitespace suppresses completion)'], $text]);
874 } else { 873 } else {
875 # @match is [command, penalty, command with arguments] until sort 874 # @match is [command, penalty, command with arguments] until sort
876 875
877 my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/; 876 my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/;
877
878 my $first_char = substr $cmd, 0, 1;
878 879
879 my $regexp_abbrev = do { 880 my $regexp_abbrev = do {
880 my ($beg, @chr) = split //, lc $cmd; 881 my ($beg, @chr) = split //, lc $cmd;
881 882
882 # the following regex is used to match our "completion entry" 883 # the following regex is used to match our "completion entry"
883 # to an actual command - the parentheses match kind of "overhead" 884 # to an actual command - the parentheses match kind of "overhead"
884 # - the more characters the parentheses match, the less attractive 885 # - the more characters the parentheses match, the less attractive
885 # is the match. 886 # is the match.
886 my $regexp = "^\Q$beg\E" 887 my $regexp = "^\Q$beg\E"
887 . join "", map "(?:.*?[ \\\\]\Q$_\E|(.*?)\Q$_\E)", @chr; 888 . join "", map "(?:.*?[ _\-]|(.*?))\Q$_\E", @chr;
888 qr<$regexp> 889 qr<$regexp>
889 }; 890 };
890 891
891 my $regexp_partial = do { 892 my $regexp_partial = do {
892 my $regexp = "^\Q$text\E(.*)"; 893 my $regexp = "^\Q$text\E(.*)";
893 qr<$regexp> 894 qr<$regexp>
894 }; 895 };
895 896
896 for (keys %{$self->{command}}) { 897 for my $list (@{ $self->{command_lists} }, "spells") {
898 for (@{ $self->{command_list}{$list} }) {
899 # we only match and score if the first character matches,
900 # so quickly rule out all others first.
901 next unless $first_char = substr $_, 0, 1;
902
897 my @scores; 903 my @scores;
898 904
899 # 1. Complete command [with args] 905 # 1. Complete command [with args]
900 # command is a prefix of the text 906 # command is a prefix of the text
901 # score is length of complete command matched 907 # score is length of complete command matched
902 # e.g. "invoke summon pet monster bat" 908 # e.g. "invoke summon pet monster bat"
903 # "invoke" "summon pet monster bat" = 6 909 # "invoke" "summon pet monster bat" = 6
904 # "invoke summon pet monster" "bat" = 25 910 # "invoke summon pet monster" "bat" = 25
905 if ($text =~ /^\Q$_\E(.*)/) { 911 if ((substr $text, 0, length $_) eq $_) {
906 push @scores, [$_, length $_, $text]; 912 push @scores, [$_, length $_, $text];
913 }
914
915 # 2. Partial command
916 # text is a prefix of the full command
917 # score is the length of the input text
918 # e.g. "invoke s"
919 # "invoke small fireball" = 8
920 # "invoke summon pet monster" = 8
921
922 if ($_ =~ $regexp_partial) {
923 push @scores, [$_, length $text, $_];
924 }
925
926 # 3. Abbreviation match
927 # attempts to use first word of text as an abbreviated command
928 # score is length of word + 1 - 3 per non-word-initial character
929
930 if (my @penalty = $_ =~ $regexp_abbrev) {
931 push @scores, [$_, (length $cmd) + 1 - (length join "", map "::$_", grep defined, @penalty), "$_$arg"];
932 }
933
934 # Pick the best option for this command
935 push @match, (sort { $b->[1] <=> $a->[1] } @scores)[0];
907 } 936 }
908
909 # 2. Partial command
910 # text is a prefix of the full command
911 # score is the length of the input text
912 # e.g. "invoke s"
913 # "invoke small fireball" = 8
914 # "invoke summon pet monster" = 8
915
916 if ($_ =~ $regexp_partial) {
917 push @scores, [$_, length $text, $_];
918 }
919
920 # 3. Abbreviation match
921 # attempts to use first word of text as an abbreviated command
922 # score is length of word + 1 - 3 per non-word-initial character
923
924 if (my @penalty = $_ =~ $regexp_abbrev) {
925 push @scores, [$_, (length $cmd) + 1 - (length join "", map "::$_", grep defined, @penalty), "$_$arg"];
926 }
927
928 # Pick the best option for this command
929 push @match, (sort {
930 $b->[1] <=> $a->[1]
931 } @scores)[0];
932 } 937 }
933 938
934 # @match is now [command object, command with arguments] 939 # @match is now [command object, command with arguments]
935 @match = map [$self->{command}{$_->[0]}, $_->[2]], 940 @match = map [$_->[0], $_->[2]],
936 sort {
937 $b->[1] <=> $a->[1] 941 sort { $b->[1] <=> $a->[1] }
938 or $self->{command}{$a->[0]}[4] <=> $self->{command}{$b->[0]}[4]
939 or (length $b->[0]) <=> (length $a->[0])
940 } @match; 942 @match;
941 } 943 }
942 944
943 $self->{last_search} = $text; 945 $self->{last_search} = $text;
944 $self->{last_match} = \@match; 946 $self->{last_match} = \@match;
945 947
974 for my $match (@matches) { 976 for my $match (@matches) {
975 my $label = shift @labels; 977 my $label = shift @labels;
976 978
977 if (@labels) { 979 if (@labels) {
978 $label->set_text ("$match->[1]"); 980 $label->set_text ("$match->[1]");
979 $label->set_tooltip ("$match->[0][1]"); 981 $label->set_tooltip ("#(command/$match->[1])");
980 } else { 982 } else {
981 $label->set_text ("..."); 983 $label->set_text ("...");
982 $label->set_tooltip ("Use Cursor-Down to view more matches"); 984 $label->set_tooltip ("Use Cursor-Down to view more matches");
983 last; 985 last;
984 } 986 }

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines