Implement !версия, !lat and !karma, cosmetic fixes

bin/train_lat.pl

@@ -0,0 +1,27 @@
+#!/usr/bin/perl
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw(:std :utf8);
+use English qw( -no_match_vars );
+use vars qw/$VERSION/;
+$VERSION = '1.0';
+
+my $workdir;
+
+# before we run, change working dir
+BEGIN {
+	use Cwd qw(chdir abs_path);
+	my @CWD = split /\//xms, abs_path ($PROGRAM_NAME);
+	if ($#CWD > 1) { $#CWD = $#CWD - 2; }
+	$workdir = join '/', @CWD;
+	chdir $workdir;
+}
+
+use lib ("$workdir/lib", "$workdir/vendor_perl", "$workdir/vendor_perl/lib/perl5");
+use lat qw(train);
+
+train ();
+exit 0;

cpanfile

@@ -1,6 +1,7 @@
 requires 'Cwd::utf8';
 requires 'DB_File';
 requires 'Digest::MD5';
+requires 'Digest::SHA';
 requires 'File::Basename';
 requires 'File::Path';
 requires 'HTTP::Tiny';
@@ -11,6 +12,8 @@ requires 'JSON::PP';
 requires 'POSIX';
 requires 'URI::URL';
 requires 'local::lib';
+
+
 # Bundled Net::Jabber::Bot deps
 # requires 'Net::Jabber::Bot';
 requires 'Moose';

data/sample_config.json

@@ -20,5 +20,11 @@
         "cachedata": "data/cache/openweathermap.Id-Data.db",
         "appid": "get_it_on_openweathermap.org"
     },
-    "debug_log" : "/var/log/aleesa-telegram-bot/debug.log"
+    "debug_log" : "/var/log/aleesa-telegram-bot/debug.log",
+    "lat" : {
+        "brain" : "data/lat/brain.sqlite"
+    },
+    "karma" : {
+        "dir" : "data/karma"
+    }
 }

lib/jabberbot.pm

@@ -14,6 +14,8 @@ use Hailo;
 
 use conf qw(loadConf);
 use botlib qw(weather logger trim randomCommonPhrase);
+use lat qw(latAnswer);
+use karma qw(karmaSet karmaGet);
 
 use Exporter qw(import);
 use vars qw/$VERSION/;
@@ -28,7 +30,7 @@ sub __background_checks {
 	my $bot = shift;
 
 	unless ($imonline) {
-		$bot->ChangeStatus('Chat', 'I\'m here');
+		$bot->ChangeStatus('Available', 'I\'m here');
 		$imonline = 1;
 	}
 
@@ -54,7 +56,6 @@ sub __new_bot_message {
 		} elsif ($text eq "$c->{jabberbot}->{aleesa}->{csign}ping") {
 			$bot->SendGroupMessage($hash{'reply_to'}, 'Pong.');
 		} elsif (substr($text, 0, 1) eq $c->{jabberbot}->{aleesa}->{csign}) {
-
 			if (substr($text, 1, 3) eq 'rum') {
 				eval {
 					$bot->SendGroupMessage(
@@ -106,24 +107,45 @@ sub __new_bot_message {
 						weather($city) =~ tr/\n/ /r
 					);
 				};
-			} elsif ((length($text) == 8 && substr($text, 1, 8) eq 'version')  ||  (length ($text) == 4 && substr($text, 1, 4) eq 'ver')) {
+			} elsif (substr($text, 1) eq 'version'  ||  substr($text, 1) eq 'ver') {
 				$bot->SendGroupMessage($hash{'reply_to'}, 'Версия нуль.чего-то_там.чего-то_там');
-			} elsif ((length ($text) == 5 && substr($text, 1, 5) eq 'help')  ||  (length ($text) == 7 && substr($text, 1, 7) eq 'помощь')) {
-				my $rate = $bot->message_delay();
-				# rate limit this :) specially for jabber.ru
-				$bot->message_delay($rate * 5);
+			} elsif (substr($text, 1) eq 'help'  ||  substr($text, 1) eq 'помощь') {
 				$bot->SendGroupMessage($hash{'reply_to'}, <<"EOL" );
 !help | !помощь - это сообщение
 !w город | !п город - погода в городе
+!lat | !лат - сгенерировать фразу из крылатого латинского выражения
 !ping | !пинг - попинговать бота
 !some_brew - выдать соответсвующий напиток, бармен может налить rum, vodka, beer, tequila, whisky, absinthe
-!ver|version - написать что-то про версию ПО
+!ver | !version | !версия - написать что-то про версию ПО
+!karma фраза | !карма фраза - посмотреть карму фразы
+фраза++ | фраза-- - повысить или понизить карму фразы
 EOL
 
+			} elsif (substr($text, 1) eq 'lat'  ||  substr($text, 1) eq 'лат') {
+				$bot->SendGroupMessage($hash{'reply_to'}, latAnswer());
+			} elsif (substr($text, 1, 6) eq 'karma '  ||  substr($text, 1, 6) eq 'карма '  ||  substr($text, 1) eq 'karma'  ||  substr($text, 1) eq 'карма') {
+				my $mytext = substr($text, 7);
+
+				if ($mytext ne '') {
+					chomp($mytext);
+					$mytext = trim($mytext);
+				}
+
+				$bot->SendGroupMessage($hash{'reply_to'}, karmaGet($hash{'reply_to'}, $mytext));
 			} else {
 				$hailo->learn($text);
 				return;
 			}
+		} elsif ((substr($text, -2) eq '++') || (substr($text, -2) eq '--')) {
+			my @arr = split(/\n/, $text);
+
+			if ($#arr < 1) {
+				my $reply = karmaSet($hash{'reply_to'}, substr($text, 0, -2), substr($text, -2));
+				$bot->SendGroupMessage($hash{'reply_to'}, $reply);
+			} else {
+				# just message in chat
+				$hailo->learn($text);
+			}
 		} else {
 			$hailo->learn($text);
 			return;

lib/karma.pm

@@ -0,0 +1,125 @@
+package karma;
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw(:std :utf8);
+use English qw( -no_match_vars );
+use Digest::SHA qw(sha1_base64);
+use DB_File;
+use Carp qw(cluck);
+
+use vars qw/$VERSION/;
+use Exporter qw(import);
+our @EXPORT_OK = qw(karmaSet karmaGet);
+
+$VERSION = '1.0';
+
+use conf qw(loadConf);
+
+my $c = loadConf();
+my $karmadir = $c->{karma}->{dir};
+my $max = 5;
+
+# swallow phrase and return answer
+sub karmaSet (@) {
+	my $chatid = shift;
+	my $phrase = shift;
+	my $action = shift;
+	my $score = 0;
+	# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only 
+	my $karmafile = join ('', unpack ('C*', $chatid));
+	$karmafile = sha1_base64 ($karmafile);
+	# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
+	$karmafile = join ('', unpack ('C*', $karmafile));
+	$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
+
+	if (($phrase eq '') || ($phrase =~ /^ +$/)) {
+		$phrase = '';
+	}
+
+	# init hash, store phrase and score
+	tie my %karma, 'DB_File', $karmafile || do {
+		cluck "Something nasty happen when cachedata ties to its data: $OS_ERROR";
+		return sprintf 'Карма %s составляет 0', $phrase;
+	};
+
+	# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
+	my $sha1_phrase = sha1_base64 (join ('', unpack ('C*', $phrase)));
+
+	if (defined $karma{$sha1_phrase}) {
+		if ($action eq '++') {
+			$score = $karma{$sha1_phrase} + 1;
+			$karma{$sha1_phrase} = $score;
+		} else {
+			$score = $karma{$sha1_phrase} - 1;
+			$karma{$sha1_phrase} = $score;
+		}
+	} else {
+		if ($action eq '++') {
+			$karma{$sha1_phrase} = 1;
+			$score = 1;
+		} else {
+			$karma{$sha1_phrase} = -1;
+			$score = -1;
+		}
+	}
+
+	untie %karma;
+
+	if ($score < -1 && (($score % (0 - $max)) + 1) == 0) {
+		if ($phrase eq '') {
+			return sprintf 'Зарегистрировано пробитие дна, карма пустоты составляет %d', $score;
+		} else {
+			return sprintf 'Зарегистрировано пробитие дна, карма %s составляет %d', $phrase, $score;
+		}
+	} else {
+		if ($phrase eq '') {
+			return sprintf 'Карма пустоты составляет %d', $score;
+		} else {
+			return sprintf 'Карма %s составляет %d', $phrase, $score;
+		}
+	}
+}
+
+# just return answer
+sub karmaGet (@) {
+	my $chatid = shift;
+	my $phrase = shift;
+	# sha1* does not understand utf8, so explicitly construct string cost of decimal numbers only 
+	my $karmafile = join ('', unpack ('C*', $chatid));
+	$karmafile = sha1_base64 ($karmafile);
+	# sha1 string can contain slashes, so make a bit longer string consist of only decimal numbers
+	$karmafile = join ('', unpack ('C*', $karmafile));
+	$karmafile = sprintf '%s/%s.db', $karmadir, $karmafile;
+
+	if (($phrase eq '') || ($phrase =~ /^ +$/)) {
+		$phrase = '';
+	}
+
+	# init hash, store phrase and score
+	tie my %karma, 'DB_File', $karmafile || do {
+		cluck "Something nasty happen when karma ties to its data: $OS_ERROR";
+		return sprintf 'Карма %s составляет 0', $phrase;
+	};
+
+	# bdb does not understand utf8, so tied hash too, we do not want store original phrase anyway
+	my $sha1_phrase = sha1_base64 (join ('', unpack ('C*', $phrase)));
+	my $score = $karma{$sha1_phrase};
+	untie %karma;
+
+	unless (defined $score) {
+		$score = 0;
+	}
+
+	if ($phrase eq '') {
+		return sprintf 'Карма пустоты составляет %d', $score;
+	} else {
+		return sprintf 'Карма %s составляет %d', $phrase, $score;
+	}
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4:

lib/lat.pm

@@ -0,0 +1,77 @@
+package lat;
+# famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw(:std :utf8);
+use English qw( -no_match_vars );
+use Carp qw(cluck);
+
+use vars qw/$VERSION/;
+use Exporter qw(import);
+our @EXPORT_OK = qw(train latAnswer);
+
+$VERSION = '1.0';
+
+use Hailo;
+use File::Basename qw(dirname);
+use File::Path qw(mkpath);
+use conf qw(loadConf);
+use botlib qw(logger);
+
+my $c = loadConf();
+my $brain = $c->{lat}->{brain};
+
+# swallow phrase and return answer
+sub train () {
+	my $braindir = dirname ($brain);
+
+	unless (-d $braindir) {
+		mkpath ($braindir) or do {
+			cluck "Unable to create $braindir: $OS_ERROR";
+			exit 1;
+		};
+	}
+
+	my $lat = Hailo->new (
+		brain => $brain,
+		# in our case mean amount of words in phase is 3
+		order => 2
+	);
+
+	$lat->train('data/phrases.txt');
+	my ($tokens, $expressions) = ($lat->stats())[0,1];
+	printf "Total tokens: %s\nTotal expressins: %s\n", $tokens, $expressions;
+	$lat->save();
+	return;
+}
+
+# just return answer
+sub latAnswer () {
+	my $braindir = dirname ($brain);
+
+	unless (-d $braindir) {
+		cluck "No lat module data: $braindir is absent! Train lat first.";
+		return '';
+	}
+
+	unless (-f $brain) {
+		cluck "No lat module data: $brain is absent! Train lat first.";
+		return '';
+	}
+
+	my $lat = Hailo->new (
+		brain => $brain,
+		# in our case mean amount of words in phase is 3
+		order => 2,
+		save_on_exit => 0
+	);
+
+	return $lat->reply();
+}
+
+1;
+
+# vim: ft=perl noet ai ts=4 sw=4 sts=4: