weaken results from the CPAN

Games-Construder

# Games::Construder - A 3D Game written in Perl with an infinite and modifiable world.
# Copyright (C) 2011  Robin Redeker
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
package Games::Construder::Server::UI;
use common::sense;
use Scalar::Util qw/weaken/;
require Exporter;
our @ISA = qw/Exporter/;
our @EXPORT = qw/
   ui_player_score
   ui_player_bio_warning
   ui_player_tagger
/;

=head1 NAME

Games::Construder::Server::UI - Server-side Userinterface for Player interaction

=over 4

=cut

sub new {
   my $this  = shift;
   my $class = ref ($this) || $this;
   my $self  = { @_ };
   bless $self, $class;

   weaken $self->{pl};

   $self->init;

   return $self
}

sub init {
}

sub layout {
   my ($self, @args) = @_;
   die "subclass responsibility\n";
}

sub commands { # subclasses should overwrite this
   my ($self) = @_;
   # key => cmd name
   ()
}

sub new_ui {
   my ($self, @args) = @_;
   $self->{pl}->new_ui (@args);
}

sub show_ui {
   my ($self, $name, @arg) = @_;
   $self->{pl}->{uis}->{$name}->show (@arg);
}

sub hide_ui {
   my ($self, $name) = @_;
   $self->{pl}->{uis}->{$name}->hide;
}

sub delete_ui {
   my ($self, @args) = @_;
   $self->{pl}->delete_ui (@args);
}

sub update {
   my ($self, @args) = @_;
   $self->show (@args) if $self->{shown};
}

sub show {
   my ($self, @args) = @_;
   my $lyout = $self->layout (@args);
   $lyout->{commands}->{default_keys} = { $self->commands };
   if ($self->{cmd_need_select_boxes}) {
      $lyout->{commands}->{need_selected_boxes} = 1;
   }
   $self->{pl}->display_ui ($self->{ui_name} => $lyout);
}

sub handle_command { # subclasses should overwrite this
}

sub react {
   my ($self, $cmd, $arg, $pos) = @_;
   return unless $self->{shown};

   $self->handle_command ($cmd, $arg, $pos);
}

sub hide {
   my ($self) = @_;
   $self->{pl}->display_ui ($self->{ui_name});
}

sub DESTROY {
   my ($self) = @_;
   $self->{pl}->display_ui ($self->{ui_name});
}

package Games::Construder::Server::UI::Score;
use Games::Construder::UI;

use base qw/Games::Construder::Server::UI/;

sub layout {
   my ($self, $hl) = @_;

   if ($hl) {
      my $wself = $self;
      weaken $wself;
      $self->{upd_score_hl_tmout} = AE::timer 1.5, 0, sub {
         $wself->show;
         delete $wself->{upd_score_hl_tmout};
      };
   }

   my $score =  $self->{pl}->{data}->{score};

   ui_hud_window ([center => "up"],
      [box => {
            border  => { color => $hl ? "#ff0000" : "#777700" },
            padding => ($hl ? 10 : 2),
            dir => "vert",
            },
         ($self->{pl}->{data}->{cheating}
            ? [text => { color => "#ff0000", font => "small", align => "center" },
               "<cheating>"]
            : ()),
         [box => {
               dir   => "hor",
               align => "center"
          },
          [text => {
             font  => "normal",
             color => "#aa8800",
             align => "center"
           }, "Score:"],
          [text => {
             font  => "big",
             color => $hl ? "#ff0000" : "#aa8800",
           }, ($score . ($hl ? ($hl > 0 ? "+$hl" : "$hl") : ""))],
         ],
      ]
   )
}

package Games::Construder::Server::UI::BioWarning;
use Games::Construder::UI;

use base qw/Games::Construder::Server::UI/;

sub layout {
   my ($self, $seconds) = @_;

   ui_hud_window_transparent (
      [center => 'center', 0, -0.15],
      ui_warning (
          "Warning: Bio energy level low! You have $seconds seconds left!"
      ),
      ui_subdesc (
       "Death imminent, please dematerialize something that provides bio energy!",
      )
   )
}

package Games::Construder::Server::UI::ProximityWarning;
use Games::Construder::UI;

use base qw/Games::Construder::Server::UI/;

sub commands {
}

sub handle_command {
   my ($self, $cmd) = @_;

}

sub layout {
   my ($self, $msg) = @_;

   my $wself = $self;
   weaken $wself;
   $self->{msg_tout} = AE::timer (3, 0, sub {
      $wself->hide;
      delete $wself->{msg_tout};
   });

   ui_hud_window_transparent (
      [center => "center", -0.25],
      ui_warning ($msg)
   );
}

package Games::Construder::Server::UI::MsgBox;
use Games::Construder::UI;

use base qw/Games::Construder::Server::UI/;

sub layout {
   my ($self, $error, $msg) = @_;

   my $wself = $self;
   weaken $wself;
   $self->{msg_tout} = AE::timer (($error ? 7 : 3), 0, sub {
      $wself->hide;
      delete $wself->{msg_tout};
   });

   ui_hud_window_transparent (
      [center => "center", 0, 0.15],
      $error
         ? ui_warning ($msg)
         : ui_notice ($msg)
   )
}

package Games::Construder::Server::UI::Slots;
use Games::Construder::UI;

use base qw/Games::Construder::Server::UI/;

sub commands {
   (
      map {
         $_ => "slot_" . ($_ == 0 ? 9 : $_ - 1)
      } 0..9
   )
}

sub handle_command {
   my ($self, $cmd, $arg, $pos) = @_;

   if ($cmd =~ /slot_(\d+)/) {
      $self->{pl}->{data}->{slots}->{selected} = $1;
      $self->show;
   }
}

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

   my $slots = $self->{pl}->{data}->{slots};

   my @slots;
   my $selected_type;
   for (my $i = 0; $i < 10; $i++) {
      my $invid = $slots->{selection}->[$i];

      my ($cnt) = $self->{pl}->{inv}->get_count ($invid);
      if ($invid =~ /:/ && $cnt == 0) {
         $slots->{selection}->[$i] = undef;
         $invid = undef;
      }

      my ($type, $invid) = $self->{pl}->{inv}->split_invid ($invid);
      if ($slots->{selected} == $i) {
         $selected_type = $type;
      }

      push @slots,
         ui_hlt_border (($i == $slots->{selected}),
            [box => { padding => 2, align => "center" },
              [model => { color => "#00ff00", width => 30 }, $type]],

lib/Games/Construder/Server/UI.pm view on Meta::CPAN

   my $obj =
      $Games::Construder::Server::RES->get_object_by_type ($selected_type)
         if $selected_type;

   ui_hud_window ([left => "down"],
      $obj ? (ui_small_text ("Selected: " . $obj->{name})) : (),
      [box => { dir => "hor" }, @{$grid[0]}],
      [box => { dir => "hor" }, @{$grid[1]}]
   )
}

package Games::Construder::Server::UI::Help;
use Games::Construder::UI;
use base qw/Games::Construder::Server::UI/;

sub layout {
   ui_window ("Server Handled Keybindings",
      ui_desc ("Global Bindings:"),
      ui_key_explain ("left mouse btn",  "Materialize block from selected slot."),
      ui_key_explain ("right mouse btn", "Dematerialize block."),
      ui_key_explain ("q",               "Query information for highlighted block."),
      ui_key_explain ("e",               "Interact with highlighted block."),
      ui_key_explain ("i",               "Open inventory."),
      ui_key_explain ("n",               "Open navigator programmer."),
      ui_key_explain ("m",               "Toggle navigator visibility."),
      ui_key_explain ("x",               "Open assignment information."),
      ui_key_explain ("o",               "Open notebook."),
      ui_key_explain ("b",               "Open material handbook."),
      ui_key_explain ("r",               "Open color selector."),
      ui_key_explain ("l",               "Create encounter (developer stuff)."),
      ui_key_explain ("h",               "Cheat."),
      ui_key_explain ("F3",              "Displays this help screen."),
      ui_key_explain ("F4",              "Opens your trophy overview."),
      ui_key_explain ("F7",              "Display Server Information."),
      ui_key_explain ("F8",              "Commit suicide, when you want to start over."),
   )
}

package Games::Construder::Server::UI::ServerInfo;
use Games::Construder::UI;

use base qw/Games::Construder::Server::UI/;

sub layout {
   ui_window ("Server Info",
      ui_text ("Server Map Directory: $Games::Construder::Server::Resources::MAPDIR"),
      ui_text ("Server Player Directory: $Games::Construder::Server::Resources::PLAYERDIR"),
   )
}

package Games::Construder::Server::UI::Status;
use Games::Construder::UI;
use Games::Construder::Server::World;

use base qw/Games::Construder::Server::UI/;

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

   my $wself = $self;
   weaken $wself;
   $self->{tmr} = AE::timer 0, 1, sub {
      $wself->show;
   };
}

sub commands {
   my ($self) = @_;
   $self->{cmd_need_select_boxes} = 1;

   (
      f2  => "menu",
      f3  => "help",
      f4  => "trophies",
      f7  => "server_info",
      f8  => "kill",
      f11 => "text_script",
      f10 => "text_script_hide",
      f12 => "exit_server",
      i   => "inventory",
      n   => "navigation_programmer",
      m   => "toggle_navigator",
      h   => "cheat",
      x   => "assignment",
      t   => "location_book",
      e   => "interact",
      q   => "query",
      o   => "notebook",
      b   => "material_handbook",
      r   => "color_select",
      l   => "encounter"
   )
}

sub handle_command {
   my ($self, $cmd, $arg, $pos) = @_;

   my $pl = $self->{pl};

   if ($cmd eq 'inventory') {
      $self->show_ui ('inventory');
   } elsif ($cmd eq 'location_book') {
      $pl->show_location_book;
   } elsif ($cmd eq 'navigation_programmer') {
      $self->show_ui ('navigation_programmer');
   } elsif ($cmd eq 'cheat') {
      $self->show_ui ('cheat');
   } elsif ($cmd eq 'contact') {
      $self->show_ui ('ship_transmission');
   } elsif ($cmd eq 'interact') {
      $pl->interact ($pos->[0]) if @{$pos->[0] || []};
   } elsif ($cmd eq 'query') {
      $pl->query ($pos->[0]);
   } elsif ($cmd eq 'assignment') {
      $self->show_ui ('assignment');
   } elsif ($cmd eq 'material_handbook') {
      $self->show_ui ('material_handbook');
   } elsif ($cmd eq 'notebook') {
      $self->show_ui ('notebook');
   } elsif ($cmd eq 'color_select') {
      $self->show_ui ('color_select');

lib/Games/Construder/Server/UI.pm view on Meta::CPAN

      $self->hide;
      $self->show_ui ('kill_player');

   } elsif ($cmd eq 'help' || $cmd eq 'menu') {
      $self->show_ui ('help');
   } elsif ($cmd eq 'toggle_navigator') {
      if ($self->{pl}->{uis}->{navigator}->{shown}) {
         $self->hide_ui ('navigator');
      } else {
         $self->show_ui ('navigator');
      }
   } elsif ($cmd eq 'trophies') {
      $self->show_ui ("trophies");
   } elsif ($cmd eq 'exit_server') {
      $self->new_ui (shutdown =>
         "Games::Construder::Server::UI::ConfirmQuery",
         msg       => "Do you really want to shutdown the server?",
         cb => sub {
            $self->delete_ui ('shutdown');
            if ($_[0]) {
               $self->{pl}->msg (0, "Shutting down the server in 2 seconds...");
               my $t; $t = AE::timer 2, 0, sub {
                  $Games::Construder::Server::World::SRV->shutdown;
                  undef $t;
               };
            }
         });
      $self->hide;
      $self->show_ui ('shutdown');
   }
}

sub _range_color {
   my ($perc, $low_ok) = @_;
   my ($first, $second) = (
      int (($low_ok / 2) / 10) * 10,
      $low_ok
   );

     $perc < $first  ? "#ff5555"
   : $perc < $second ? "#ffff55"
   : "#55ff55"
}

sub time2str {
   my $m = int ($_[0] / 60);
   sprintf "%2dm %2ds", $m, $_[0] - ($m * 60)
}

sub layout {
   my ($self, $bio_usage) = @_;

   my $abs_pos  = $self->{pl}->get_pos_normalized;
   my $chnk_pos = $self->{pl}->get_pos_chnk;
   my $sec_pos  = $self->{pl}->get_pos_sector;

   my $sinfo = world_sector_info ($chnk_pos);

   if (ref $bio_usage) {
      my $wself = $self;
      weaken $wself;
      $self->{bio_intake} = $bio_usage;
      $self->{bio_intake_tmr} = AE::timer 2, 0, sub {
         delete $wself->{bio_intake};
         $wself->show;
         delete $wself->{bio_intake_tmr};
      };

   } elsif ($bio_usage) {
      my $wself = $self;
      weaken $wself;
      $self->{bio_usage} = $bio_usage;
      $self->{bio_usage_tmr} = AE::timer 2, 0, sub {
         delete $wself->{bio_usage};
         $wself->show;
         delete $wself->{bio_usage_tmr};
      };
   }

   ui_hud_window (
     [right => 'up'],
     ui_border (
        [box => { dir => "hor" },
           [box => { dir => "vert", padding => 2 },
              [text => { color => "#FFFF88", font => "small" }, "Time"],
              [text => { color => "#888888", font => "small" }, "Pos"],
              #d#[text => { color => "#888888", font => "small" }, "Look"],
              [text => { color => "#888888", font => "small" }, "Chunk"],
              [text => { color => "#888888", font => "small" }, "Sector"],
              [text => { color => "#888888", font => "small" }, "Type"],
           ],
           [box => { dir => "vert", padding => 2 },
              [text => { color => "#ffffff", font => "small" },
                 time2str ($self->{pl}->{data}->{time})],
              [text => { color => "#ffffff", font => "small" },
                 sprintf ("%3d,%3d,%3d", @$abs_pos)],
              #d#[text => { color => "#ffffff", font => "small" },
              #d#   sprintf ("%3d,%3d,%3d", @{vsmul ($self->{data}->{look_vec}, 10)})],
              [text => { color => "#ffffff", font => "small" },
                 sprintf ("%3d,%3d,%3d", @$chnk_pos)],
              [text => { color => "#ffffff", font => "small" },
                 sprintf ("%3d,%3d,%3d", @$sec_pos)],
              [text => { color => "#ffffff", font => "small" },
                 sprintf ("%s, %0.5f", $sinfo->{type}, $sinfo->{param})],
           ]
        ],
        [box => { },
           [text => { align => "right", font => "big", color => _range_color ($self->{pl}->{data}->{happyness}, 90), max_chars => 4 },
              sprintf ("%d%%", $self->{pl}->{data}->{happyness})],
           [text => { align => "center", color => "#888888" }, "happy"],
        ],
        [box => { },
           [text => { align => "right", font => "big", color => _range_color ($self->{pl}->{data}->{bio}, 60), max_chars => 4 },
              sprintf ("%d%%", $self->{pl}->{data}->{bio})],
           ($self->{bio_intake}
              ? [box => { dir => "hor", align => "left" },
                   [text => { align => "center", font => "big", color => "#00ff00", wrap => -2 }, "+"],
                   [model => { animated => 0, align => "center", width => 30 }, $self->{bio_intake}->[0]]]
              : [text => { align => "center", color => "#888888" }, "bio"])
        ],
        ($self->{bio_usage}
           ? [box => { },
              [text => { align => "center", color => "#FFaa00" }, "-$self->{bio_usage}% bio"]]
           : ()),
        [box => { },
           [text => { align => "right",
                      color => $self->{pl}->{data}->{signal_jammed}
                         ? "#00ff00" : "#ff0000" },
              $self->{pl}->{data}->{signal_jammed} ? "Jammed" : "Clear"],
           [text => { align => "center", color => "#888888" }, " signal"],
        ],

( run in 2.081 seconds using v1.01-cache-2.11-cpan-437f7b0c052 )