Deliantra-Client

 view release on metacpan or  search on metacpan

DC/MapWidget.pm  view on Meta::CPAN

               or next;
            my $server = $::CONN->{editor_support}{"${type}server"}
               or next;

            push @items, [
               "Login on $type server <span size='xx-small'>(" . (DC::asxml $server) . ")</span>",
               sub { server_login $server },
            ];
         }
      }

      push @items,
         ["Quit",
            sub {
               if ($::CONN) {
                  &::open_quit_dialog;
               } else {
                  exit;
               }
            }
         ],
      ;

      (new DC::UI::Menu
         items => \@items,
      )->popup ($ev);
   }

   1
}

sub invoke_button_up {
   my ($self, $ev, $x, $y) = @_;

   delete $self->{motion};

   1
}

sub invoke_mouse_motion {
   my ($self, $ev, $x, $y) = @_;

   if ($self->{motion}) {
      $self->{motion}->($ev, $x, $y);
   } else {
      return 0;
   }

   1
}

sub size_request {
   my ($self) = @_;

   (
      $self->{tilesize} * DC::ceil $::WIDTH  / $self->{tilesize},
      $self->{tilesize} * DC::ceil $::HEIGHT / $self->{tilesize},
   )
}

sub update {
   my ($self) = @_;

   $self->{need_update} = 1;
   $self->SUPER::update;
}

my %DIR = (
   ( "," . DC::SDLK_KP5      ), [0, "stay fire"],
   ( "," . DC::SDLK_KP8      ), [1, "north"],
   ( "," . DC::SDLK_KP9      ), [2, "northeast"],
   ( "," . DC::SDLK_KP6      ), [3, "east"],
   ( "," . DC::SDLK_KP3      ), [4, "southeast"],
   ( "," . DC::SDLK_KP2      ), [5, "south"],
   ( "," . DC::SDLK_KP1      ), [6, "southwest"],
   ( "," . DC::SDLK_KP4      ), [7, "west"],
   ( "," . DC::SDLK_KP7      ), [8, "northwest"],

   ( "," . DC::SDLK_PAGEUP   ), [2, "northeast"],
   ( "," . DC::SDLK_PAGEDOWN ), [4, "southeast"],
   ( "," . DC::SDLK_END      ), [6, "southwest"],
   ( "," . DC::SDLK_HOME     ), [8, "northwest"],

   ( "," . DC::SDLK_UP       ), [1, "north"],
   ("1," . DC::SDLK_UP       ), [2, "northeast"],
   ( "," . DC::SDLK_RIGHT    ), [3, "east"],
   ("1," . DC::SDLK_RIGHT    ), [4, "southeast"],
   ( "," . DC::SDLK_DOWN     ), [5, "south"],
   ("1," . DC::SDLK_DOWN     ), [6, "southwest"],
   ( "," . DC::SDLK_LEFT     ), [7, "west"],
   ("1," . DC::SDLK_LEFT     ), [8, "northwest"],
);

sub invoke_key_down {
   my ($self, $ev) = @_;

   my $mod = $ev->{mod};
   my $sym = $ev->{sym};
   my $uni = $ev->{unicode};

   $mod &= DC::KMOD_CTRL | DC::KMOD_ALT | DC::KMOD_META | DC::KMOD_SHIFT;

   # ignore repeated keypresses
   return if $self->{last_mod} == $mod && $self->{last_sym} == $sym;
   $self->{last_mod} = $mod;
   $self->{last_sym} = $sym;

   my $dir = $DIR{ (!!($mod & (DC::KMOD_ALT | DC::KMOD_META))) . ",$sym" };

   if ($::CONN && $dir) {
      if ($mod & DC::KMOD_SHIFT) {
         $self->{shft}++;
         if ($dir->[0] != $self->{fire_dir}) {
            $::CONN->user_send ("fire $dir->[0]");
         }
         $self->{fire_dir} = $dir->[0];
      } elsif ($mod & DC::KMOD_CTRL) {
         $self->{ctrl}++;
         $::CONN->user_send ("run $dir->[0]");
      } else {
         $::CONN->user_send ("$dir->[1]");

DC/MapWidget.pm  view on Meta::CPAN

sub size_request {
   ($::HEIGHT * 0.2, $::HEIGHT * 0.2)
}

sub refresh_hook {
   my ($self) = @_;

   if ($::MAP && $self->{texture_atime} < time) {
      my ($w, $h) = @$self{qw(w h)};

      return unless $w && $h;

      my $sw = int $::WIDTH  / ($::MAPWIDGET->{tilesize} * $::CFG->{map_scale}) + 0.99;
      my $sh = int $::HEIGHT / ($::MAPWIDGET->{tilesize} * $::CFG->{map_scale}) + 0.99;

      my $ox = 0.5 * ($w - $sw);
      my $oy = 0.5 * ($h - $sh);

      my $sx = int $::CFG->{map_shift_x} / $::MAPWIDGET->{tilesize};
      my $sy = int $::CFG->{map_shift_y} / $::MAPWIDGET->{tilesize};

      #TODO: map scale is completely borked

      my $x0 = int $ox - $sx + 0.5;
      my $y0 = int $oy - $sy + 0.5;

      $self->{sw} = $sw;
      $self->{sh} = $sh;

      $self->{x0} = $x0;
      $self->{y0} = $y0;

      $self->{texture_atime} = time + 1/3;

      $self->{texture} =
         new DC::Texture
            w    => $w,
            h    => $h,
            data => $::MAP->mapmap (-$ox, -$oy, $w, $h),
            type => $DC::GL_VERSION >= 1.2 ? GL_UNSIGNED_INT_8_8_8_8_REV : GL_UNSIGNED_BYTE;
   }
}

sub invoke_visibility_change {
   my ($self) = @_;

   $self->refresh_hook;

   0
}

sub invoke_size_allocate {
   my ($self, $w, $h) = @_;

   $self->update;

   1
}

sub update {
   my ($self) = @_;

   delete $self->{texture_atime};
   $self->SUPER::update;
}

sub _draw {
   my ($self) = @_;

   $self->{root}->on_post_alloc (texture => sub { $self->refresh_hook });

   $self->{texture} or return;

   glEnable GL_BLEND;
   glBlendFunc GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA;
   glEnable GL_TEXTURE_2D;
   glTexEnv GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE;

   $self->{texture}->draw_quad (0, 0);

   glDisable GL_TEXTURE_2D;

   glTranslate 0.375, 0.375;

   glColor 1, 1, 0, 1;
   glBegin GL_LINE_LOOP;
   glVertex $self->{x0}              , $self->{y0}              ;
   glVertex $self->{x0}              , $self->{y0} + $self->{sh};
   glVertex $self->{x0} + $self->{sw}, $self->{y0} + $self->{sh};
   glVertex $self->{x0} + $self->{sw}, $self->{y0}              ;
   glEnd;
   
   glDisable GL_BLEND;
}

package DC::MapWidget::Command;

use common::sense;

use DC::OpenGL;

our @ISA = DC::UI::Frame::;

sub new {
   my $class = shift;

   my $self = $class->SUPER::new (
      bg => [0, 0, 0, 0.8],
      @_,
   );

   $self->add ($self->{vbox} = new DC::UI::VBox);

   $self->{label} = [
      map
         DC::UI::Label->new (
            align         => 0,
            can_hover     => 1,
            can_events    => 1,
            tooltip_width => 0.33,

DC/MapWidget.pm  view on Meta::CPAN

                  $self->{hist_ptr}++;
               }
               $self->{entry}->set_text ($self->{history}->[$self->{hist_ptr} - 1])
                  if exists $self->{history}->[$self->{hist_ptr} - 1];
            }
            $self->update_labels;
         } else {
            return 0;
         }

         1
      }
   ;

   $self->{vbox}->add (
      $self->{entry},
      @{$self->{label}},
   );

   $self
}

sub set_prefix {
   my ($self, $prefix) = @_;

   $self->{entry}->set_text ($prefix);
   $self->show;
}

sub invoke_size_allocate {
   my ($self, $w, $h) = @_;

   $self->move_abs (($::WIDTH - $w) * 0.5, ($::HEIGHT - $h) * 0.6, 10);

   $self->SUPER::invoke_size_allocate ($w, $h)
}

sub show {
   my ($self) = @_;

   $self->SUPER::show;
   $self->{entry}->grab_focus;
}

sub hide {
   my ($self) = @_;

   $self->{hist_ptr} = 0;

   $self->SUPER::hide;
   $self->{entry}->set_text ("");
}

sub inject_key_down {
   my ($self, $ev) = @_;

   $self->{entry}->grab_focus;
   $self->{entry}->emit (key_down => $ev);
}

sub update_labels {
   my ($self) = @_;

   my $text = $self->{entry}->get_text;

   length $text
      or return $self->hide;

   if ($text ne $self->{last_search}) {
      my @match;

      if ($text =~ /^(.*?)\s+$/) {
         my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/;
         @match = ([[$cmd,'(appended whitespace suppresses completion)'],$text]);
      } else {
         # @match is [command, penalty, command with arguments] until sort

         my ($cmd, $arg) = $text =~ /^\s*([^[:space:]]*)(.*)$/;

         my $regexp_abbrev = do {
            my ($beg, @chr) = split //, lc $cmd;

            # the following regex is used to match our "completion entry"
            # to an actual command - the parentheses match kind of "overhead"
            # - the more characters the parentheses match, the less attractive
            # is the match.
            my $regexp = "^\Q$beg\E"
                       . join "", map "(?:.*?[ \\\\]\Q$_\E|(.*?)\Q$_\E)", @chr;
            qr<$regexp>
         };

         my $regexp_partial = do {
            my $regexp = "^\Q$text\E(.*)";
            qr<$regexp>
         };

         for (keys %{$self->{command}}) {
            my @scores;

            # 1. Complete command [with args]
            #    command is a prefix of the text
            #    score is length of complete command matched
            #    e.g. "invoke summon pet monster bat"
            #         "invoke" "summon pet monster bat" = 6
            #         "invoke summon pet monster" "bat" = 25
            if ($text =~ /^\Q$_\E(.*)/) {
               push @scores, [$_, length $_, $text];
            }

            # 2. Partial command
            #    text is a prefix of the full command
            #    score is the length of the input text
            #    e.g. "invoke s"
            #         "invoke small fireball" = 8
            #         "invoke summon pet monster" = 8

            if ($_ =~ $regexp_partial) {
               push @scores, [$_, length $text, $_];
            }

            # 3. Abbreviation match