200 lines
7 KiB
Perl
200 lines
7 KiB
Perl
package Bot::BasicBot::Pluggable::Module::DirkMod;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use base 'Bot::BasicBot::Pluggable::Module::Infobot';
|
|
use LWP::Simple;
|
|
use JSON::XS;
|
|
use Time::Duration;
|
|
|
|
my $world_url = "http://dirkocraft.com:8123/up/world/main/";
|
|
|
|
sub get_player_pos {
|
|
my ($self, $user) = @_;
|
|
|
|
return "I don't work from IRC" if ($user eq "IRC");
|
|
|
|
no warnings 'uninitialized';
|
|
if (time - $self->{_pos}{lastupdate} >= 60) { # only actually update every 60 seconds
|
|
$self->{_pos}{players} = {}; #clear the users, since i don't want to figure out when people disconnnect
|
|
my $cont = get($world_url); # get the json for the server
|
|
my $strut = decode_json($cont);
|
|
|
|
for my $player (@{$strut->{players}}) {
|
|
my $key = lc $player->{name};
|
|
$self->{_pos}{players}{$key} = $player;
|
|
}
|
|
|
|
$self->{_pos}{lastupdate} = time;
|
|
}
|
|
|
|
if (exists($self->{_pos}{players}{lc $user})) { # we know where that user was
|
|
my $pl = $self->{_pos}{players}{lc $user};
|
|
my $time = ago(time - $self->{_pos}{lastupdate}); # TODO does this need to be in perfect sync with above? probably not
|
|
my $coords = sprintf "world '%s' at %dx %dy %dz", @{$pl}{qw/world x y z/};
|
|
return "$user was in $coords $time";
|
|
} else {
|
|
return "Are you sure that '$user' is on? They might be in the nether where I can't see.";
|
|
}
|
|
}
|
|
|
|
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 $body = $mess->{body} || "";
|
|
|
|
my $is_priv = !defined $mess->{channel} || $mess->{channel} eq 'msg';
|
|
|
|
my $user = "IRC";
|
|
if ($mess->{who} =~ /^dirkocraft\d*$/) {
|
|
$body =~ s/^(\([^\)]+\)) //;
|
|
$user = $1;
|
|
}
|
|
|
|
# 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}/g;
|
|
|
|
$factoid =~ s/\$coords/$self->get_player_pos($user)/eg;
|
|
|
|
# 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;
|