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.163 by root, Thu Oct 14 00:02:39 2010 UTC vs.
Revision 1.168 by root, Wed Nov 21 13:23:10 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
… …
620} 601}
621 602
622sub refresh_hook { 603sub refresh_hook {
623 my ($self) = @_; 604 my ($self) = @_;
624 605
625 if ($::MAP && $self->{texture_atime} < EV::now) { 606 if ($::MAP && $self->{texture_atime} < AE::now) {
626 my ($w, $h) = @$self{qw(w h)}; 607 my ($w, $h) = @$self{qw(w h)};
627 608
628 return unless $w && $h; 609 return unless $w && $h;
629 610
630 my $sw = int $::WIDTH / ($::MAPWIDGET->{tilesize} * $::CFG->{map_scale}) + 0.99; 611 my $sw = int $::WIDTH / ($::MAPWIDGET->{tilesize} * $::CFG->{map_scale}) + 0.99;
… …
645 $self->{sh} = $sh; 626 $self->{sh} = $sh;
646 627
647 $self->{x0} = $x0; 628 $self->{x0} = $x0;
648 $self->{y0} = $y0; 629 $self->{y0} = $y0;
649 630
650 $self->{texture_atime} = EV::now + 1/2; 631 $self->{texture_atime} = AE::now + 1/2;
651 632
652 $self->{texture} = 633 $self->{texture} =
653 new DC::Texture 634 new DC::Texture
654 w => $w, 635 w => $w,
655 h => $h, 636 h => $h,
… …
816 ); 797 );
817 798
818 $self 799 $self
819} 800}
820 801
802sub reset {
803 my ($self) = @_;
804
805 $self->hide;
806 delete $self->{command_list};
807}
808
821sub set_prefix { 809sub set_prefix {
822 my ($self, $prefix) = @_; 810 my ($self, $prefix) = @_;
823 811
824 $self->{entry}->set_text ($prefix); 812 $self->{entry}->set_text ($prefix);
825 $self->show; 813 $self->show;
… …
861 849
862 my $text = $self->{entry}->get_text; 850 my $text = $self->{entry}->get_text;
863 851
864 length $text 852 length $text
865 or return $self->hide; 853 or return $self->hide;
854
855 return unless $::CONN;
856
857 # regenerate spell list if necessary
858 $self->{command_list}{spells} ||= [
859 map { ("cast $_->{name}", "invoke $_->{name}") }
860 values %{ $::CONN->{spell} }
861 ];
866 862
867 if ($text ne $self->{last_search}) { 863 if ($text ne $self->{last_search}) {
868 my @match; 864 my @match;
869 865
870 if ($text =~ /^(.*?)\s+$/) { 866 if ($text =~ /^(.*?)\s+$/) {
… …
873 } else { 869 } else {
874 # @match is [command, penalty, command with arguments] until sort 870 # @match is [command, penalty, command with arguments] until sort
875 871
876 my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/; 872 my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/;
877 873
874 my $first_char = substr $cmd, 0, 1;
875
878 my $regexp_abbrev = do { 876 my $regexp_abbrev = do {
879 my ($beg, @chr) = split //, lc $cmd; 877 my ($beg, @chr) = split //, lc $cmd;
880 878
881 # the following regex is used to match our "completion entry" 879 # the following regex is used to match our "completion entry"
882 # to an actual command - the parentheses match kind of "overhead" 880 # to an actual command - the parentheses match kind of "overhead"
883 # - the more characters the parentheses match, the less attractive 881 # - the more characters the parentheses match, the less attractive
884 # is the match. 882 # is the match.
885 my $regexp = "^\Q$beg\E" 883 my $regexp = "^\Q$beg\E"
886 . join "", map "(?:.*?[ \\\\]\Q$_\E|(.*?)\Q$_\E)", @chr; 884 . join "", map "(?:.*?[ _\-]|(.*?))\Q$_\E", @chr;
887 qr<$regexp> 885 qr<$regexp>
888 }; 886 };
889 887
890 my $regexp_partial = do { 888 my $regexp_partial = do {
891 my $regexp = "^\Q$text\E(.*)"; 889 my $regexp = "^\Q$text\E(.*)";
892 qr<$regexp> 890 qr<$regexp>
893 }; 891 };
894 892
895 for (keys %{$self->{command}}) { 893 for my $list (values %{ $self->{command_list} }) {
894 for (@$list) {
895 # we only match and score if the first character matches,
896 # so quickly rule out all others first.
897 next unless $first_char = substr $_, 0, 1;
898
896 my @scores; 899 my @scores;
897 900
898 # 1. Complete command [with args] 901 # 1. Complete command [with args]
899 # command is a prefix of the text 902 # command is a prefix of the text
900 # score is length of complete command matched 903 # score is length of complete command matched
901 # e.g. "invoke summon pet monster bat" 904 # e.g. "invoke summon pet monster bat"
902 # "invoke" "summon pet monster bat" = 6 905 # "invoke" "summon pet monster bat" = 6
903 # "invoke summon pet monster" "bat" = 25 906 # "invoke summon pet monster" "bat" = 25
904 if ($text =~ /^\Q$_\E(.*)/) { 907 if ((substr $text, 0, length $_) eq $_) {
905 push @scores, [$_, length $_, $text]; 908 push @scores, [$_, length $_, $text];
909 }
910
911 # 2. Partial command
912 # text is a prefix of the full command
913 # score is the length of the input text
914 # e.g. "invoke s"
915 # "invoke small fireball" = 8
916 # "invoke summon pet monster" = 8
917
918 if ($_ =~ $regexp_partial) {
919 push @scores, [$_, length $text, $_];
920 }
921
922 # 3. Abbreviation match
923 # attempts to use first word of text as an abbreviated command
924 # score is length of word + 1 - 3 per non-word-initial character
925
926 if (my @penalty = $_ =~ $regexp_abbrev) {
927 push @scores, [$_, (length $cmd) + 1 - (length join "", map "::$_", grep defined, @penalty), "$_$arg"];
928 }
929
930 # Pick the best option for this command
931 push @match, (sort {
932 $b->[1] <=> $a->[1]
933 } @scores)[0];
906 } 934 }
907
908 # 2. Partial command
909 # text is a prefix of the full command
910 # score is the length of the input text
911 # e.g. "invoke s"
912 # "invoke small fireball" = 8
913 # "invoke summon pet monster" = 8
914
915 if ($_ =~ $regexp_partial) {
916 push @scores, [$_, length $text, $_];
917 }
918
919 # 3. Abbreviation match
920 # attempts to use first word of text as an abbreviated command
921 # score is length of word + 1 - 3 per non-word-initial character
922
923 if (my @penalty = $_ =~ $regexp_abbrev) {
924 push @scores, [$_, (length $cmd) + 1 - (length join "", map "::$_", grep defined, @penalty), "$_$arg"];
925 }
926
927 # Pick the best option for this command
928 push @match, (sort {
929 $b->[1] <=> $a->[1]
930 } @scores)[0];
931 } 935 }
932 936
933 # @match is now [command object, command with arguments] 937 # @match is now [command object, command with arguments]
934 @match = map [$self->{command}{$_->[0]}, $_->[2]], 938 @match = map [$self->{command}{$_->[0]}, $_->[2]],
935 sort { 939 sort {

Diff Legend

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