levelbot
25/01/2006, 12:08:09
Para os que não conhecem este plugin, o Kadiliman faz com que seu bot "aprenda" a conversar.
É muito normal e rotineiro o bot encontrar outros jogadores e com isso é quase que inevitável o início de um diálogo. Com o Kadiliman você pode escrever frases completas em um arquivo chamado lines.txt que o plugin selecionará automaticamente uma dessas frases e irá responder, tanto em chat privativo, clã ou mensagem pública.
Irei explicar detalhadamente como se instalar este divertido plugin.
Versão do Kore exigida: SVN 1.9.1. ou superior
Crie um arquivos chamado kadiliman.pl ,coloque o código abaixo e grave na sua pasta plugins:
package kadiliman;
use strict;
use Plugins;
use Globals;
use Log qw(message warning error);
use Misc;
use Network;
use Network::Send;
use Chatbot::Kadiliman;
Plugins::register('kadiliman', 'autoresponse bot', \&Unload, \&Reload);
my $hooks = Plugins::addHooks(
['packet/public_chat', \&onMessage, undef],
['packet/private_message', \&onMessage, undef],
['packet/system_chat', \&onMessage, undef],
['packet/guild_chat', \&onMessage, undef],
['packet/party_chat', \&onMessage, undef],
['start3', \&start3, undef],
['AI_post', \&AI_post, undef]
);
my $prefix = "chatBot_";
my %bot;
message "Initializing chatBot\n", "plugins";
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
$bot{$i} = new Chatbot::Kadiliman {
};
}
sub Unload {
Plugins::delHooks($hooks);
}
sub Reload {
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
message "Plugin Kadiliman: checking for duplicate lines in ". $config{$prefix.$i."_scriptfile"} ."...", "plugins";
checkForDupes($config{$prefix.$i."_scriptfile"});
message "done.\n", "plugins";
$bot{$i} = new Chatbot::Kadiliman {
name => $config{$prefix.$i},
scriptfile => $config{$prefix.$i."_scriptfile"},
learn => $config{$prefix.$i."_learn"},
reply => 1,
};
}
}
sub onMessage {
my ($packet, $args) = @_;
my $prefix = "chatBot_";
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
return if (($args->{privMsgUser} || $args->{chatMsgUser}) eq $char->{name});
$bot{$i}->{reply} = ($config{$prefix.$i."_replyRate"}) ? 1 : 0;
$config{$prefix.$i."_replyRate"} = 80 if (!exists $config{$prefix.$i."_replyRate"});
$config{$prefix.$i."_replyRate"} = 100 if ($config{$prefix.$i."_replyRate"} > 100);
my $type;
my $reply;
if ($packet eq 'packet/public_chat' && $config{$prefix.$i."_onPublicChat"}) {
$reply = $bot{$i}->transform($args->{chatMsg});
$type = "c";
} elsif ($packet eq 'packet/system_chat' && $config{$prefix.$i."_onSystemChat"}) {
my $msg = $args->{message};
my ($chatMsgUser, $chatMsg);
if ($msg =~/:/) {
($chatMsgUser, $chatMsg) = $msg =~ /(.*?).:.(.*)/;
} else {
$chatMsg = $msg;
}
$reply = $bot{$i}->transform($chatMsg);
$type = "c";
} elsif ($packet eq 'packet/guild_chat' && $config{$prefix.$i."_onGuildChat"}) {
$reply = $bot{$i}->transform($args->{chatMsg});
$type = "g";
} elsif ($packet eq 'packet/party_chat' && $config{$prefix.$i."_onPartyChat"}) {
$reply = $bot{$i}->transform($args->{chatMsg});
$type = "p";
} elsif ($packet eq 'packet/private_message' && $config{$prefix.$i."_onPrivateMessage"}) {
$reply = $bot{$i}->transform($args->{privMsg});
$type = "pm";
}
# exit if the config option is not enabled
return if (!$type);
# exit if we don't have any reply
return if (!$reply);
# add a smiley at the end of the reply
my @smileys = split /\,+/, $config{$prefix.$i."_smileys"};
$reply .= $smileys[rand(@smileys)] if ((rand(100) < ($config{$prefix.$i."_smileyRate"})));
## COPIED FROM processChatResponse, ChatQueue.pm
# Calculate a small delay (to simulate typing)
# The average typing speed is 65 words per minute.
# The average length of a word used by RO players is 4.25 characters (yes I measured it).
# So the average user types 65 * 4.25 = 276.25 charcters per minute, or
# 276.25 / 60 = 4.6042 characters per second
# We also add a random delay of 0.5-1.5 seconds.
$args->{wpm} = $config{$prefix.$i."_wpm"} || 65;
my @words = split /\s+/, $reply;
my $average;
foreach my $word (@words) {
$average += length($word);
}
$average /= (scalar @words);
my $typeSpeed = $args->{wpm} * $average / 60;
$args->{timeout} = (0.5 + rand(1)) + (length($reply) / $typeSpeed);
$args->{time} = time;
$args->{stage} = "start";
$args->{reply} = $reply;
$args->{prefix} = $prefix.$i;
$args->{type} = $type;
my $rand = rand(100);
message "$rand : " . $config{$prefix.$i."_replyRate"} . "\n";
AI::queue("chatBot", $args)
if ((AI::action ne 'chatBot')
&& ($rand < ($config{$prefix.$i."_replyRate"}))
&& ($bot{$i}->{reply})
&& (main::checkSelfCondition($prefix))
);
}
}
sub start3 {
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
#message "Plugin Kadiliman: checking for duplicate lines in ". $config{$prefix.$i."_scriptfile"} ."...", "plugins";
#checkForDupes($config{$prefix.$i."_scriptfile"});
message "done.\n", "plugins";
$bot{$i} = new Chatbot::Kadiliman {
name => $config{$prefix.$i},
scriptfile => $config{$prefix.$i."_scriptfile"},
learn => $config{$prefix.$i."_learn"},
reply => 1,
};
}
}
sub AI_post {
if (AI::action eq 'chatBot') {
my $args = AI::args;
if ($args->{stage} eq 'end') {
AI::dequeue;
} elsif ($args->{stage} eq 'start') {
$args->{stage} = 'message' if (main::timeOut($args->{time}, $args->{timeout}));
} elsif ($args->{stage} eq 'message') {
sendMessage($net, $args->{type}, $args->{reply}, $args->{privMsgUser});
message "chatBot: $args->{reply}\n", "plugins";
$args->{stage} = 'end';
}
}
}
sub checkForDupes {
my $scriptfile = shift;
my %self;
$scriptfile = "lines.txt" if ($scriptfile eq 1);
# read scriptfile in (the whole thing, all at once).
my @scriptlines;
if (open (SCRIPTFILE, "<$scriptfile")) {
@scriptlines = <SCRIPTFILE>; # read in script data
close (SCRIPTFILE);
}
# check for duplicate lines
for (my $i = 0; $i < (scalar @scriptlines); $i++) {
for (my $j = $i + 1; $j < (scalar @scriptlines); $j++) {
$scriptlines[$i] = '' if ($scriptlines[$i] eq $scriptlines[$j]);
}
}
# save cleaned-up file
open (SCRIPTFILE, ">$scriptfile");
foreach my $line (@scriptlines) {
print SCRIPTFILE ("$line");
}
close (SCRIPTFILE);
}
return 1;
Feito isso iremos precisar de outro arquivo. Crie uma pasta chamada Chatbot, (escreva exatamente Chabot). Esta pasta tem que estar obrigatoriamente dentro da pasta src.
É dentro da pasta Chatbot que iremos criar um arquivo chamado Kadiliman.pm.
Coloque o código abaixo dentro do arquivo Kadiliman.pm.
Inspired by perlBorg, pyBorg, and seeBorg
# Licensed under the GPL
# Copyright by kaliwanagan
package Chatbot::Kadiliman;
use strict;
use vars qw($VERSION @ISA $AUTOLOAD) ;
$VERSION = '0.06';
sub Version { $VERSION; }
my %fields;
%fields = {
name => 'Kadiliman',
scriptfile => '',
depth => 3,
learn => 0,
reply => 1,
debug => 0,
debug_text => '',
quit => undef
};
sub new {
my ($that, $name, $scriptfile) = @_;
my $class = ref($that) || $that;
my $self = {
_permitted => \%fields,
%fields,
};
bless $self, $class;
$self->_initialize($name, $scriptfile);
return $self;
}
sub _initialize {
my ($self, $name, $scriptfile) = @_;
if (defined $name and ref $name eq "HASH") {
# Allow the calling program to pass in intial parameters
# as an anonymous hash
map { $self->{$_} = $name->{$_}; } keys %$name;
$self->parseScriptData( $self->{scriptfile} );
} else {
$self->{name} = $name if $name;
$self->parseScriptData($scriptfile);
}
}
sub parseScriptData {
my ($self, $scriptfile) = @_;
$self->debug("Parsing $scriptfile... ");
my @scriptlines;
if ($scriptfile) {
# If we have an external script file, open it
# and read it in (the whole thing, all at once).
if (open (SCRIPTFILE, "<$scriptfile")) {
@scriptlines = <SCRIPTFILE>; # read in script data
$self->{scriptfile} = $scriptfile;
close (SCRIPTFILE);
} else {
print "Could not read from file $scriptfile : $!\n";
print "Creating default lines.txt ...\n";
$self->{scriptfile} = "lines.txt";
}
$self->debug("done\n");
}
$self->debug("Learning $scriptfile... ");
foreach my $line (@scriptlines) {
my @sentences = split /\.+/, $line;
foreach my $sentence (@sentences) {
$self->learn($sentence);
}
}
$self->debug("done\n");
$self->debug("I know ". scalar @{$self->{lines}} . " lines.\n") if (exists $self->{lines});
$self->{parsed} = 1;
}
sub saveScriptData {
my ($self) = @_;
$self->debug("Saving script data... ");
my $scriptfile = $self->{scriptfile};
open (SCRIPTFILE, ">$scriptfile");
foreach my $line (@{$self->{lines}}) {
print SCRIPTFILE ("$line\n");
}
close (SCRIPTFILE);
$self->debug("done.\n");
}
sub learn {
my ($self, $string) = @_;
my $numLines = (exists $self->{lines}) ? @{$self->{lines}} : '0';
$string = $self->preProcess($string);
my $tmp = $string;
$tmp = lc $tmp; # convert to lowercase
$tmp =~ s/[^A-Za-z_0-9 \']/ /g; # remove non alpha-numeric characters
my @words = split /\s+/, $tmp;
for (my $i = 0; $i < scalar @words; $i++) {
$self->{count}{$words[$i]}++;
$self->{after}{$words[$i]}{$words[$i+1]}++ if ($words[$i+1]);
push @{$self->{linenum}{$words[$i]}}, $numLines;
}
push @{$self->{lines}}, $string if ($string);
if ($self->{parsed}) {
$self->debug("Learning: $string\n");
}
}
sub preProcess {
my ($self, $string) = @_;
$string =~ s/\n//g; # remove newlines
$string =~ s/\r//g; # remove cariage returns;
$string =~ s/^_*//; #remove leading underscores
$string =~ s/_*$//; #remove trailing underscores
$string =~ s/^\s*//; #remove leading spaces
$string =~ s/\s*$//; #remove trailing spaces
return $string;
}
sub postProcess {
my ($self, $string) = @_;
}
sub transform {
my ($self, $inputString) = @_;
my $reply;
my $input = $self->preProcess($inputString);
# Filter out all the words we haven't learned yet
my @leftWords;
$input = lc $input; # convert to lowercase
$input =~ s/[^A-Za-z_0-9 \']/ /g; # remove non alpha-numeric characters
my @words = split /\s+/, $input;
foreach my $word (@words) {
$self->debug("$word: $self->{count}{$word}\n");
next if (!exists ($self->{count}{$word}));
push @leftWords, $word;
}
undef @words;
# Choose a word from the list of known words
my $leftWord = $leftWords[int rand(@leftWords)];
$self->debug("Chosen left word: $leftWord\n");
undef @leftWords;
if (!$leftWord) { # if all words are unknown
$reply = $self->{lines}[int rand(@{$self->{lines}})];
} else {
my @rightWords = keys %{$self->{after}{$leftWord}};
my $rightWord = $rightWords[int rand(@rightWords)];
$self->debug("Chosen right word: $rightWord\n");
undef @rightWords;
my @leftLines;
my @rightLines;
my $string;
# Cull from script data all lines containing the left word
foreach my $linenum (@{$self->{linenum}{$leftWord}}) {
push @leftLines, $self->{lines}[$linenum];
}
$self->debug("leftLines: " . scalar @leftLines . "\n");
# Cull from script data all lines containing the right word
foreach my $linenum (@{$self->{linenum}{$rightWord}}) {
push @rightLines, $self->{lines}[$linenum];
}
$self->debug("rightLines: " . scalar @rightLines . "\n");
my $rand;
# Get a random line from those that contain the left word
$rand = int rand(@leftLines);
$string = $leftLines[$rand];
# Build the left side
my $leftSide;
my @words = split /\s+/, $string;
foreach my $word (@words) {
$leftSide = $leftSide . $word . ' ';
last if $word =~ /\b$leftWord\b/;
}
undef @words;
$self->debug("Leftside: $leftSide line: $rand\n");
# Get a random line from those that contain the right word
$rand = int rand(@rightLines);
$string = $rightLines[$rand];
# Build the right side
my $rightSide;
my @words = split /\s+/, $string;
foreach my $word (@words) {
last if $word =~ /\b$rightWord\b/;
$word = '';
}
foreach my $word (@words) {
$rightSide .= $word ? $word . ' ' : '';
}
undef @words;
$self->debug("Rightside: $rightSide line: $rand\n");
# Build the reply
$reply = $leftSide . $rightSide;
}
$self->learn($inputString) if ($self->{learn});
$self->saveScriptData if ($self->{learn});
return $reply;
}
sub _testquit {
my ($self, $string) = @_;
return 1 if ($string =~ /\bquit\b/i);
}
sub command_interface {
my $self = shift;
my $userInput;
while (1) {
chomp($userInput = <STDIN>);
if($self->_testquit($userInput)) {
last;
}
print "Reply: ".$self->transform($userInput)."\n";
}
}
sub debug {
my ($self, $string) = @_;
print "debug -> $string" if ($self->{debug});
}
return 1;
=head1 CHANGES
=over 4
= item * Version 0.06 (21 July 2005)
fix for regexp dying on unescaped characters (thanks Joseph)
= item * Version 0.05 (18 July 2005)
changed from a simple word selection into word + wordafter selection
= item * Version 0.04 (17 July 2005)
First release
= item * Version 0.03 (17 July 2005)
complete learn and transform functions
changed from rare word to random word selection
= item * Version 0.02 (15 July 2005)
preProcess function
learn function (partial)
transform function (partial)
= item * Version 0.01 (8 July 2005)
Created skeleton code
=back
=cut
Com os dois srquivos criados vamos ao nosso config.txt. Abra seu config.txt e coloque o seguinte bloco de comando:
chatBot Kadiliman {
scriptfile lines.txt
learn 1
reply 1
onPublicMessage 1
onPrivateMessage 1
onSystemChat 1
onGuildChat 1
onPartyChat 1
wpm 65
replyRate 80
smileys ^_^,;P ,:) , >, XD
smileyRate 20
}
Quando você iniciar com o Kadiliman provavelmente seu lines.txt estará vazio, ou seja, sem muitas frases ou quem sabe você não quer que seu bot "aprenda" ou grave frases que você não deseja. Para habilitar o modo de aprendizado:
learn 1 - todas as frases serão gravadas no lines.txt
learn - não será gravado nada. Observe que não é pra colocar 0 (zero) pra inibir a gravação deixe sem nada.
OBS: o arquivo lines.txt estará na pasta raiz do seu kore
replay 1 - Utiliza uma frase aleatória para a resposta
replay - Não responde. Tome muito cuidado com as fraes que você vai deixar no seu lines.txt
onPublicMessage 1 - Grava mensagens públicas
onPrivateMessage 1 - Grava mensagens Privativas
onSystemChat 1 - Grava mensagens do sistema (Não aconselhável)
onGuildChat 1 - Grava mensagens do clã
onPartyChat 1 - Grava mensagens do grupo
OBS: Para desabilitar a gravação de algum tipo de mensagem substitua o 1 por 0 (zero)
Créditos para kaliwanagan...
É muito normal e rotineiro o bot encontrar outros jogadores e com isso é quase que inevitável o início de um diálogo. Com o Kadiliman você pode escrever frases completas em um arquivo chamado lines.txt que o plugin selecionará automaticamente uma dessas frases e irá responder, tanto em chat privativo, clã ou mensagem pública.
Irei explicar detalhadamente como se instalar este divertido plugin.
Versão do Kore exigida: SVN 1.9.1. ou superior
Crie um arquivos chamado kadiliman.pl ,coloque o código abaixo e grave na sua pasta plugins:
package kadiliman;
use strict;
use Plugins;
use Globals;
use Log qw(message warning error);
use Misc;
use Network;
use Network::Send;
use Chatbot::Kadiliman;
Plugins::register('kadiliman', 'autoresponse bot', \&Unload, \&Reload);
my $hooks = Plugins::addHooks(
['packet/public_chat', \&onMessage, undef],
['packet/private_message', \&onMessage, undef],
['packet/system_chat', \&onMessage, undef],
['packet/guild_chat', \&onMessage, undef],
['packet/party_chat', \&onMessage, undef],
['start3', \&start3, undef],
['AI_post', \&AI_post, undef]
);
my $prefix = "chatBot_";
my %bot;
message "Initializing chatBot\n", "plugins";
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
$bot{$i} = new Chatbot::Kadiliman {
};
}
sub Unload {
Plugins::delHooks($hooks);
}
sub Reload {
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
message "Plugin Kadiliman: checking for duplicate lines in ". $config{$prefix.$i."_scriptfile"} ."...", "plugins";
checkForDupes($config{$prefix.$i."_scriptfile"});
message "done.\n", "plugins";
$bot{$i} = new Chatbot::Kadiliman {
name => $config{$prefix.$i},
scriptfile => $config{$prefix.$i."_scriptfile"},
learn => $config{$prefix.$i."_learn"},
reply => 1,
};
}
}
sub onMessage {
my ($packet, $args) = @_;
my $prefix = "chatBot_";
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
return if (($args->{privMsgUser} || $args->{chatMsgUser}) eq $char->{name});
$bot{$i}->{reply} = ($config{$prefix.$i."_replyRate"}) ? 1 : 0;
$config{$prefix.$i."_replyRate"} = 80 if (!exists $config{$prefix.$i."_replyRate"});
$config{$prefix.$i."_replyRate"} = 100 if ($config{$prefix.$i."_replyRate"} > 100);
my $type;
my $reply;
if ($packet eq 'packet/public_chat' && $config{$prefix.$i."_onPublicChat"}) {
$reply = $bot{$i}->transform($args->{chatMsg});
$type = "c";
} elsif ($packet eq 'packet/system_chat' && $config{$prefix.$i."_onSystemChat"}) {
my $msg = $args->{message};
my ($chatMsgUser, $chatMsg);
if ($msg =~/:/) {
($chatMsgUser, $chatMsg) = $msg =~ /(.*?).:.(.*)/;
} else {
$chatMsg = $msg;
}
$reply = $bot{$i}->transform($chatMsg);
$type = "c";
} elsif ($packet eq 'packet/guild_chat' && $config{$prefix.$i."_onGuildChat"}) {
$reply = $bot{$i}->transform($args->{chatMsg});
$type = "g";
} elsif ($packet eq 'packet/party_chat' && $config{$prefix.$i."_onPartyChat"}) {
$reply = $bot{$i}->transform($args->{chatMsg});
$type = "p";
} elsif ($packet eq 'packet/private_message' && $config{$prefix.$i."_onPrivateMessage"}) {
$reply = $bot{$i}->transform($args->{privMsg});
$type = "pm";
}
# exit if the config option is not enabled
return if (!$type);
# exit if we don't have any reply
return if (!$reply);
# add a smiley at the end of the reply
my @smileys = split /\,+/, $config{$prefix.$i."_smileys"};
$reply .= $smileys[rand(@smileys)] if ((rand(100) < ($config{$prefix.$i."_smileyRate"})));
## COPIED FROM processChatResponse, ChatQueue.pm
# Calculate a small delay (to simulate typing)
# The average typing speed is 65 words per minute.
# The average length of a word used by RO players is 4.25 characters (yes I measured it).
# So the average user types 65 * 4.25 = 276.25 charcters per minute, or
# 276.25 / 60 = 4.6042 characters per second
# We also add a random delay of 0.5-1.5 seconds.
$args->{wpm} = $config{$prefix.$i."_wpm"} || 65;
my @words = split /\s+/, $reply;
my $average;
foreach my $word (@words) {
$average += length($word);
}
$average /= (scalar @words);
my $typeSpeed = $args->{wpm} * $average / 60;
$args->{timeout} = (0.5 + rand(1)) + (length($reply) / $typeSpeed);
$args->{time} = time;
$args->{stage} = "start";
$args->{reply} = $reply;
$args->{prefix} = $prefix.$i;
$args->{type} = $type;
my $rand = rand(100);
message "$rand : " . $config{$prefix.$i."_replyRate"} . "\n";
AI::queue("chatBot", $args)
if ((AI::action ne 'chatBot')
&& ($rand < ($config{$prefix.$i."_replyRate"}))
&& ($bot{$i}->{reply})
&& (main::checkSelfCondition($prefix))
);
}
}
sub start3 {
for (my $i = 0; (exists $config{$prefix.$i}); $i++) {
#message "Plugin Kadiliman: checking for duplicate lines in ". $config{$prefix.$i."_scriptfile"} ."...", "plugins";
#checkForDupes($config{$prefix.$i."_scriptfile"});
message "done.\n", "plugins";
$bot{$i} = new Chatbot::Kadiliman {
name => $config{$prefix.$i},
scriptfile => $config{$prefix.$i."_scriptfile"},
learn => $config{$prefix.$i."_learn"},
reply => 1,
};
}
}
sub AI_post {
if (AI::action eq 'chatBot') {
my $args = AI::args;
if ($args->{stage} eq 'end') {
AI::dequeue;
} elsif ($args->{stage} eq 'start') {
$args->{stage} = 'message' if (main::timeOut($args->{time}, $args->{timeout}));
} elsif ($args->{stage} eq 'message') {
sendMessage($net, $args->{type}, $args->{reply}, $args->{privMsgUser});
message "chatBot: $args->{reply}\n", "plugins";
$args->{stage} = 'end';
}
}
}
sub checkForDupes {
my $scriptfile = shift;
my %self;
$scriptfile = "lines.txt" if ($scriptfile eq 1);
# read scriptfile in (the whole thing, all at once).
my @scriptlines;
if (open (SCRIPTFILE, "<$scriptfile")) {
@scriptlines = <SCRIPTFILE>; # read in script data
close (SCRIPTFILE);
}
# check for duplicate lines
for (my $i = 0; $i < (scalar @scriptlines); $i++) {
for (my $j = $i + 1; $j < (scalar @scriptlines); $j++) {
$scriptlines[$i] = '' if ($scriptlines[$i] eq $scriptlines[$j]);
}
}
# save cleaned-up file
open (SCRIPTFILE, ">$scriptfile");
foreach my $line (@scriptlines) {
print SCRIPTFILE ("$line");
}
close (SCRIPTFILE);
}
return 1;
Feito isso iremos precisar de outro arquivo. Crie uma pasta chamada Chatbot, (escreva exatamente Chabot). Esta pasta tem que estar obrigatoriamente dentro da pasta src.
É dentro da pasta Chatbot que iremos criar um arquivo chamado Kadiliman.pm.
Coloque o código abaixo dentro do arquivo Kadiliman.pm.
Inspired by perlBorg, pyBorg, and seeBorg
# Licensed under the GPL
# Copyright by kaliwanagan
package Chatbot::Kadiliman;
use strict;
use vars qw($VERSION @ISA $AUTOLOAD) ;
$VERSION = '0.06';
sub Version { $VERSION; }
my %fields;
%fields = {
name => 'Kadiliman',
scriptfile => '',
depth => 3,
learn => 0,
reply => 1,
debug => 0,
debug_text => '',
quit => undef
};
sub new {
my ($that, $name, $scriptfile) = @_;
my $class = ref($that) || $that;
my $self = {
_permitted => \%fields,
%fields,
};
bless $self, $class;
$self->_initialize($name, $scriptfile);
return $self;
}
sub _initialize {
my ($self, $name, $scriptfile) = @_;
if (defined $name and ref $name eq "HASH") {
# Allow the calling program to pass in intial parameters
# as an anonymous hash
map { $self->{$_} = $name->{$_}; } keys %$name;
$self->parseScriptData( $self->{scriptfile} );
} else {
$self->{name} = $name if $name;
$self->parseScriptData($scriptfile);
}
}
sub parseScriptData {
my ($self, $scriptfile) = @_;
$self->debug("Parsing $scriptfile... ");
my @scriptlines;
if ($scriptfile) {
# If we have an external script file, open it
# and read it in (the whole thing, all at once).
if (open (SCRIPTFILE, "<$scriptfile")) {
@scriptlines = <SCRIPTFILE>; # read in script data
$self->{scriptfile} = $scriptfile;
close (SCRIPTFILE);
} else {
print "Could not read from file $scriptfile : $!\n";
print "Creating default lines.txt ...\n";
$self->{scriptfile} = "lines.txt";
}
$self->debug("done\n");
}
$self->debug("Learning $scriptfile... ");
foreach my $line (@scriptlines) {
my @sentences = split /\.+/, $line;
foreach my $sentence (@sentences) {
$self->learn($sentence);
}
}
$self->debug("done\n");
$self->debug("I know ". scalar @{$self->{lines}} . " lines.\n") if (exists $self->{lines});
$self->{parsed} = 1;
}
sub saveScriptData {
my ($self) = @_;
$self->debug("Saving script data... ");
my $scriptfile = $self->{scriptfile};
open (SCRIPTFILE, ">$scriptfile");
foreach my $line (@{$self->{lines}}) {
print SCRIPTFILE ("$line\n");
}
close (SCRIPTFILE);
$self->debug("done.\n");
}
sub learn {
my ($self, $string) = @_;
my $numLines = (exists $self->{lines}) ? @{$self->{lines}} : '0';
$string = $self->preProcess($string);
my $tmp = $string;
$tmp = lc $tmp; # convert to lowercase
$tmp =~ s/[^A-Za-z_0-9 \']/ /g; # remove non alpha-numeric characters
my @words = split /\s+/, $tmp;
for (my $i = 0; $i < scalar @words; $i++) {
$self->{count}{$words[$i]}++;
$self->{after}{$words[$i]}{$words[$i+1]}++ if ($words[$i+1]);
push @{$self->{linenum}{$words[$i]}}, $numLines;
}
push @{$self->{lines}}, $string if ($string);
if ($self->{parsed}) {
$self->debug("Learning: $string\n");
}
}
sub preProcess {
my ($self, $string) = @_;
$string =~ s/\n//g; # remove newlines
$string =~ s/\r//g; # remove cariage returns;
$string =~ s/^_*//; #remove leading underscores
$string =~ s/_*$//; #remove trailing underscores
$string =~ s/^\s*//; #remove leading spaces
$string =~ s/\s*$//; #remove trailing spaces
return $string;
}
sub postProcess {
my ($self, $string) = @_;
}
sub transform {
my ($self, $inputString) = @_;
my $reply;
my $input = $self->preProcess($inputString);
# Filter out all the words we haven't learned yet
my @leftWords;
$input = lc $input; # convert to lowercase
$input =~ s/[^A-Za-z_0-9 \']/ /g; # remove non alpha-numeric characters
my @words = split /\s+/, $input;
foreach my $word (@words) {
$self->debug("$word: $self->{count}{$word}\n");
next if (!exists ($self->{count}{$word}));
push @leftWords, $word;
}
undef @words;
# Choose a word from the list of known words
my $leftWord = $leftWords[int rand(@leftWords)];
$self->debug("Chosen left word: $leftWord\n");
undef @leftWords;
if (!$leftWord) { # if all words are unknown
$reply = $self->{lines}[int rand(@{$self->{lines}})];
} else {
my @rightWords = keys %{$self->{after}{$leftWord}};
my $rightWord = $rightWords[int rand(@rightWords)];
$self->debug("Chosen right word: $rightWord\n");
undef @rightWords;
my @leftLines;
my @rightLines;
my $string;
# Cull from script data all lines containing the left word
foreach my $linenum (@{$self->{linenum}{$leftWord}}) {
push @leftLines, $self->{lines}[$linenum];
}
$self->debug("leftLines: " . scalar @leftLines . "\n");
# Cull from script data all lines containing the right word
foreach my $linenum (@{$self->{linenum}{$rightWord}}) {
push @rightLines, $self->{lines}[$linenum];
}
$self->debug("rightLines: " . scalar @rightLines . "\n");
my $rand;
# Get a random line from those that contain the left word
$rand = int rand(@leftLines);
$string = $leftLines[$rand];
# Build the left side
my $leftSide;
my @words = split /\s+/, $string;
foreach my $word (@words) {
$leftSide = $leftSide . $word . ' ';
last if $word =~ /\b$leftWord\b/;
}
undef @words;
$self->debug("Leftside: $leftSide line: $rand\n");
# Get a random line from those that contain the right word
$rand = int rand(@rightLines);
$string = $rightLines[$rand];
# Build the right side
my $rightSide;
my @words = split /\s+/, $string;
foreach my $word (@words) {
last if $word =~ /\b$rightWord\b/;
$word = '';
}
foreach my $word (@words) {
$rightSide .= $word ? $word . ' ' : '';
}
undef @words;
$self->debug("Rightside: $rightSide line: $rand\n");
# Build the reply
$reply = $leftSide . $rightSide;
}
$self->learn($inputString) if ($self->{learn});
$self->saveScriptData if ($self->{learn});
return $reply;
}
sub _testquit {
my ($self, $string) = @_;
return 1 if ($string =~ /\bquit\b/i);
}
sub command_interface {
my $self = shift;
my $userInput;
while (1) {
chomp($userInput = <STDIN>);
if($self->_testquit($userInput)) {
last;
}
print "Reply: ".$self->transform($userInput)."\n";
}
}
sub debug {
my ($self, $string) = @_;
print "debug -> $string" if ($self->{debug});
}
return 1;
=head1 CHANGES
=over 4
= item * Version 0.06 (21 July 2005)
fix for regexp dying on unescaped characters (thanks Joseph)
= item * Version 0.05 (18 July 2005)
changed from a simple word selection into word + wordafter selection
= item * Version 0.04 (17 July 2005)
First release
= item * Version 0.03 (17 July 2005)
complete learn and transform functions
changed from rare word to random word selection
= item * Version 0.02 (15 July 2005)
preProcess function
learn function (partial)
transform function (partial)
= item * Version 0.01 (8 July 2005)
Created skeleton code
=back
=cut
Com os dois srquivos criados vamos ao nosso config.txt. Abra seu config.txt e coloque o seguinte bloco de comando:
chatBot Kadiliman {
scriptfile lines.txt
learn 1
reply 1
onPublicMessage 1
onPrivateMessage 1
onSystemChat 1
onGuildChat 1
onPartyChat 1
wpm 65
replyRate 80
smileys ^_^,;P ,:) , >, XD
smileyRate 20
}
Quando você iniciar com o Kadiliman provavelmente seu lines.txt estará vazio, ou seja, sem muitas frases ou quem sabe você não quer que seu bot "aprenda" ou grave frases que você não deseja. Para habilitar o modo de aprendizado:
learn 1 - todas as frases serão gravadas no lines.txt
learn - não será gravado nada. Observe que não é pra colocar 0 (zero) pra inibir a gravação deixe sem nada.
OBS: o arquivo lines.txt estará na pasta raiz do seu kore
replay 1 - Utiliza uma frase aleatória para a resposta
replay - Não responde. Tome muito cuidado com as fraes que você vai deixar no seu lines.txt
onPublicMessage 1 - Grava mensagens públicas
onPrivateMessage 1 - Grava mensagens Privativas
onSystemChat 1 - Grava mensagens do sistema (Não aconselhável)
onGuildChat 1 - Grava mensagens do clã
onPartyChat 1 - Grava mensagens do grupo
OBS: Para desabilitar a gravação de algum tipo de mensagem substitua o 1 por 0 (zero)
Créditos para kaliwanagan...