351 lines
11 KiB
Perl
351 lines
11 KiB
Perl
package Bot::BasicBot::Pluggable::Module::DirkMod;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use base 'Bot::BasicBot::Pluggable::Module::Infobot';
|
|
use JSON::XS;
|
|
use Time::Duration;
|
|
use LWP::Simple qw();
|
|
|
|
use Text::LevenshteinXS qw(distance);
|
|
use List::Util qw(reduce);
|
|
use Data::Dumper;
|
|
use YAML qw(LoadFile);
|
|
|
|
# TODO this might need to change if dynmap fixes their json
|
|
our $world_url = "http://map.dirkocraft.com/up/world/main/";
|
|
our $playerstate = {}; # keep these global! is something funny happenign with the modules?
|
|
|
|
our $resdb;
|
|
|
|
sub checkres {
|
|
my ($res, $world, $x, $y, $z) = @_;
|
|
my $areas = $res->{Areas};
|
|
|
|
for my $area (keys %$areas) {
|
|
my ($mx, $my, $mz, $nx, $ny, $nz) = @{$res->{Areas}{$area}}{qw(X2 Y2 Z2 X1 Y1 Z1)};
|
|
my $rworld = $res->{Permissions}{World};
|
|
|
|
print "WORLD: $rworld $world\n";
|
|
|
|
if ($world eq $rworld && $x >= $mx && $y >= $my && $z >= $mz && $x < $nx && $y < $ny && $z < $nz) { # check the rectangle
|
|
return 1;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub getsubzone
|
|
{
|
|
my ($zones, $world, $x, $y, $z) = @_;
|
|
|
|
for my $zone (keys %$zones) {
|
|
print "CHECKING $zone\n";
|
|
my $zhr = $zones->{$zone};
|
|
if (checkres($zhr, $world, $x, $y, $z)) {
|
|
return ($zone, getsubzone($zhr->{Subzones}, $world, $x, $y, $z));
|
|
}
|
|
}
|
|
|
|
return ();
|
|
}
|
|
|
|
sub findres {
|
|
my ($world, $x, $y, $z) = @_;
|
|
|
|
print Dumper \@_;
|
|
|
|
my @names = getsubzone($resdb->{Residences}, $world, $x, $y, $z);
|
|
|
|
return join ".", @names;
|
|
}
|
|
|
|
sub loadres
|
|
{
|
|
$resdb = LoadFile("var/res.yml");
|
|
}
|
|
|
|
sub optipeep {
|
|
my ($peep, $input) = @_;
|
|
|
|
my $l = length($input);
|
|
|
|
#print "CHECKING $input $peep\n";
|
|
|
|
my $min = [length($peep)*10, $peep]; # set maxes
|
|
for my $p (0..length($peep)-length($input)) {
|
|
my $subpeep = substr($peep, $p, $l);
|
|
my $d = distance($input, substr($peep, $p, $l));
|
|
# print "LOOKING $p $subpeep $d\n";
|
|
if ($d <= $min->[0]) {
|
|
$min = [$d, $peep]
|
|
}
|
|
}
|
|
|
|
return $min
|
|
}
|
|
|
|
sub get_seen {
|
|
my ($self, $user) = @_;
|
|
my $seen = $self->bot->module("MySeen");
|
|
|
|
my $out = $seen->told({body => "seen ".$user});
|
|
|
|
return $out;
|
|
}
|
|
|
|
sub get_player_pos {
|
|
my ($user) = @_;
|
|
|
|
return "I don't work from IRC" if ($user eq "IRC");
|
|
|
|
no warnings 'uninitialized';
|
|
if (time - $playerstate->{lastupdate} >= 60) { # only actually update every 60 seconds
|
|
print "FETCHING\n";
|
|
$playerstate->{players} = {}; #clear the users, since i don't want to figure out when people disconnnect
|
|
my $cont = LWP::Simple::get($world_url); # get the json for the server
|
|
my $strut = decode_json($cont);
|
|
|
|
for my $player (@{$strut->{players}}) {
|
|
my $key = lc $player->{name};
|
|
$playerstate->{players}{$key} = $player;
|
|
}
|
|
|
|
$playerstate->{lastupdate} = time;
|
|
loadres();
|
|
}
|
|
|
|
my @peeps = keys %{$playerstate->{players}};
|
|
|
|
my $peep = reduce {$a->[0] > $b->[0] ? $b : $a} map {optipeep($_, $user)} @peeps;
|
|
#print Dumper($peep);
|
|
$user = $peep->[1] if ($peep->[0] < 5); # don't set it if it's too large
|
|
|
|
if (exists($playerstate->{players}{lc $user})) { # we know where that user was
|
|
my $pl = $playerstate->{players}{lc $user};
|
|
my $time = ago(time - $playerstate->{lastupdate}); # TODO does this need to be in perfect sync with above? probably not
|
|
my ($world, $x, $y, $z) = @{$pl}{qw/world x y z/};
|
|
my $resname = findres($world, $x, $y, $z);
|
|
my $coords = sprintf "world '%s' at %dx %dy %dz", $world, int $x, $y+1, int $z, $resname;
|
|
my $realname = $pl->{name};
|
|
my $out = "$realname was in ";
|
|
|
|
if ($resname) {
|
|
$out .= $resname . " ($coords)";
|
|
} else {
|
|
$out .= "($coords)";
|
|
}
|
|
|
|
$out .= " $time";
|
|
return $out;
|
|
} else {
|
|
return "Are you sure that '$user' is on? They might be in the nether where I can't see.";
|
|
}
|
|
}
|
|
|
|
my $counter = 0;
|
|
sub tick { # called every 5 seconds
|
|
my $self = shift; # get ourself, duh
|
|
|
|
unless ($counter++ % 48) {# every 4 minutes, 48 * 5 seconds, send the message
|
|
my $mess = {body => "to_wanderer",
|
|
who => "automatic",
|
|
where => "#dirkocraft-wanderer",
|
|
address => 0,
|
|
};
|
|
};
|
|
}
|
|
|
|
sub told {
|
|
my ( $self, $mess ) = @_;
|
|
my $body = $mess->{body};
|
|
return unless defined $body;
|
|
|
|
# direct commands must be addressed.
|
|
return unless $mess->{address};
|
|
|
|
if ( $body =~ /^forget\s+(.*)$/i ) {
|
|
return $self->delete_factoid($1)
|
|
? "I forgot about $1."
|
|
: "I don't know anything about $1.";
|
|
}
|
|
|
|
# search for a particular factoid.
|
|
if ( $body =~ /^search\s+for\s+(.*)$/i ) {
|
|
return "privmsg only, please" unless ( $mess->{channel} eq "msg" );
|
|
return "searching disabled" unless $self->get("user_allow_searching");
|
|
my @results = $self->search_factoid( split( /\s+/, $1 ) );
|
|
unless (@results) { return "I don't know anything about $1."; }
|
|
$#results = $self->get("user_num_results") - 1
|
|
unless $#results < $self->get("user_num_results");
|
|
return "I know about: " . join( ", ", map { "'$_'" } @results ) . ".";
|
|
}
|
|
}
|
|
|
|
sub fallback {
|
|
my ( $self, $mess ) = @_;
|
|
my $seen = $self->bot->module("MySeen");
|
|
my $body = $mess->{body} || "";
|
|
|
|
my $is_priv = !defined $mess->{channel} || $mess->{channel} eq 'msg';
|
|
return if ($mess->{channel} eq '#dirkocraft-alert' || $mess->{channel} eq '#dirkocraft-local');
|
|
|
|
my $user = "IRC";
|
|
if ($mess->{who} =~ /^dirkocraft\d*$/) {
|
|
$body =~ s/^\(([^)]+)\)\s+//;
|
|
$user = $1;
|
|
}
|
|
|
|
#23:05:18 < dirkocraft> [XmasPteradactyl disconnected]
|
|
#23:05:21 < dirkocraft> [CaveScavenger disconnected]
|
|
if ($mess->{who} =~ /^dirkocraft\d*$/ && $body =~ /\[(\S+) disconnected\]/) {
|
|
$seen->update_seen($1, "Minecraft", "losing the game");
|
|
}
|
|
elsif ($mess->{who} =~ /^dirkocraft\d*$/ && $body =~ /\[(\S+) connected\]/) {
|
|
$seen->update_seen($1, "Minecraft", "winning the game")
|
|
}
|
|
else {
|
|
$seen->update_seen($user, "Minecraft", "saying '".$body."'"); # update people!
|
|
}
|
|
|
|
if ($body =~ /^!coords\s+(.*)/i) { # TODO ok this isn't robust, but it'll work for now
|
|
$user = $1;
|
|
$body = "!coords"; # rewrite the body
|
|
};
|
|
|
|
if ($body =~ /^!seen\s+(.*)/i) { # TODO ok this isn't robust, but it'll work for now
|
|
$user = $1;
|
|
$body = "!seen"; # rewrite the body
|
|
};
|
|
|
|
# request starts with "my", so we'll look for
|
|
# a valid factoid for "$mess->{who}'s $object".
|
|
$body =~ s/^my /$mess->{who}'s /;
|
|
|
|
my %stopwords =
|
|
map { lc($_) => 1 }
|
|
split( /\s*[\s,\|]\s*/, $self->get("user_stopwords") );
|
|
|
|
# checks to see if something starts
|
|
# <word> (is|are)
|
|
# and then removes if if <word> is a stopword
|
|
# this means that we treat "what is foo?" as "foo?"
|
|
if ( $body =~ /^(.*?)\s+(is|are)\s+(.*)$/i ) {
|
|
$body =~ s/^(.*?)\s+(is|are)\s+//i if $stopwords{$1};
|
|
}
|
|
|
|
# answer a factoid. this is a crazy check which ensures we will ONLY answer
|
|
# a factoid if a) there is, or isn't, a question mark, b) we have, or haven't,
|
|
# been addressed, c) the factoid is bigger and smaller than our requirements,
|
|
# and d) that it doesn't look like a to-be-learned factoid (which is important
|
|
# if the user has disabled the requiring of the question mark for answering.)
|
|
my $body_regexp =
|
|
$self->get("user_require_question") && !$is_priv ? qr/\?+$/ : qr/[.!?]*$/;
|
|
if ( $body =~ s/$body_regexp//
|
|
and ( $mess->{address} or $self->get("user_passive_answer") )
|
|
and length($body) >= $self->get("user_min_length")
|
|
and length($body) <= $self->get("user_max_length")
|
|
and $body !~ /^(.*?)\s+(is|are)\s+(.*)$/i )
|
|
{
|
|
# get the factoid and type of relationship
|
|
my ( $is_are, $factoid, $literal ) = $self->get_factoid($body);
|
|
if ( !$literal && $factoid && $factoid =~ /\|/ ) {
|
|
my @f = split /\|/, $factoid;
|
|
$factoid = $f[ int( rand( scalar @f ) ) ];
|
|
}
|
|
|
|
# no factoid?
|
|
unless ($factoid) {
|
|
my @unknowns = split( /\|/, $self->get("user_unknown_responses") );
|
|
my $unknown = $unknowns[ int( rand( scalar(@unknowns) ) ) - 1 ];
|
|
return $mess->{address} ? $unknown : undef;
|
|
}
|
|
|
|
# variable substitution.
|
|
$factoid =~ s/\$who/$mess->{who}/ig;
|
|
|
|
$factoid =~ s/\$coords/get_player_pos($user)/eig;
|
|
$factoid =~ s/\$seen/get_seen($self,$user)/eig;
|
|
|
|
if ($factoid =~ /\$alert\$/i && $mess->{channel} =~ /dirkocraft$/i) { # if we see $ALERT$ and we're in the main channel
|
|
$mess->{channel} = "#dirkocraft-alert";
|
|
$factoid =~ s/\$alert\$//ig;
|
|
$self->bot->say({who => $mess->{channel},
|
|
channel => $mess->{channel},
|
|
body => $factoid});
|
|
return 1; # say nothing in the main channel
|
|
}
|
|
|
|
# emote?
|
|
if ( $factoid =~ s/^<action>\s*//i ) {
|
|
$self->bot->emote(
|
|
{
|
|
who => $mess->{who},
|
|
channel => $mess->{channel},
|
|
body => $factoid
|
|
}
|
|
);
|
|
return 1;
|
|
|
|
# replying with, or without a noun? hmMmMmmm?!
|
|
}
|
|
elsif ($literal) {
|
|
$body =~ s!^literal\s+!!;
|
|
return "$body =${is_are}= $factoid";
|
|
}
|
|
else {
|
|
return $factoid =~ s/^<reply>\s*//i
|
|
? $factoid
|
|
: $factoid;
|
|
}
|
|
}
|
|
|
|
# the only thing left is learning factoids. are we
|
|
# addressed or are we willing to learn passively?
|
|
# does it even look like a factoid?
|
|
return unless ( $mess->{address} or $self->get("user_passive_learn") );
|
|
return
|
|
unless ( $body =~ /^(.*?)\s+(is)\s+(.*)$/i
|
|
or $body =~ /^(.*?)\s+(are)\s+(.*)$/i );
|
|
my ( $object, $is_are, $description ) = ( $1, $2, $3 );
|
|
my $literal = ( $object =~ s!^literal\s+!! );
|
|
|
|
# allow corrections and additions.
|
|
my ( $nick, $replace, $also ) = ( $self->bot->nick, 0, 0 );
|
|
$replace = 1 if ( $object =~ s/no,?\s+//i ); # no, $object is $fact.
|
|
$replace = 1
|
|
if ( $replace and $object =~ s/^\s*$nick,?\s*//i )
|
|
; # no, $bot, $object is $fact.
|
|
$also = 1 if ( $description =~ s/^also\s+//i ); # $object is also $fact.
|
|
|
|
# ignore short, long, and stopword'd factoids.
|
|
return if length($object) < $self->get("user_min_length");
|
|
return if length($object) > $self->get("user_max_length");
|
|
foreach ( keys %stopwords ) { return if $object =~ /^$_\b/; }
|
|
|
|
# if we're replacing things, remove the factoid first.
|
|
# $also check supports "no, $bot, $object is also $fact".
|
|
if ( $replace and !$also ) {
|
|
$self->delete_factoid($object);
|
|
}
|
|
|
|
# get any current factoid there might be.
|
|
my ( $type, $current ) = $self->get_factoid($object);
|
|
|
|
# we can't add without explicit instruction,
|
|
# but shouldn't warn if this is passive.
|
|
if ( $current and !$also and $mess->{address} ) {
|
|
return "... but $object $type $current ...";
|
|
}
|
|
elsif ( $current and !$also and !$mess->{address} ) {
|
|
return;
|
|
}
|
|
|
|
# add this factoid. this comment is absolutely useless. excelsior.
|
|
$self->add_factoid( $object, $is_are, split( /\s+or\s+/, $description ) );
|
|
|
|
# return an ack if we were addressed only
|
|
return $mess->{address} ? "Okay." : 1;
|
|
}
|
|
|
|
1;
|