Prep for gamestat implementation

* Move artifacts to separate files + Implement db seed with artifacts + Add gamedata_seed.pl script to seed artifacts to db
2021-07-02 15:41:21 +03:00
parent 30fb568de0
commit eddbcc6277
9 changed files with 337 additions and 113 deletions
--- a/.gitignore
+++ b/.gitignore
@@ -1,13 +1,15 @@
 _Deparsed_XSubs.pm
 .idea/**
 .vscode/**
+.vstags
 aleesa-telegram-bot.pid
 data/cache/**
 data/config.json
 data/fortune/**
 data/friday/**
-data/karma/**
-data/telegrambot-brains/**
-data/lat/**
+data/gamestat/**
 data/image/**
+data/karma/**
+data/lat/**
+data/telegrambot-brains/**
 vendor_perl/**
--- a/bin/gamedata_seed.pl
+++ b/bin/gamedata_seed.pl
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use English qw ( -no_match_vars );
+use version; our $VERSION = qw (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 BotLib::Gamestat qw (SeedArtifacts);
+
+SeedArtifacts ();
+exit 0;
--- a/3
+++ b/3
@@ -5,6 +5,8 @@ requires 'Cwd::utf8';
 requires 'DateTime';
 requires 'DB_File';
 requires 'SQLite_File';
+requires 'DBI';
+requires 'DBD::SQLite';
 requires 'Digest::HMAC_SHA1';
 requires 'Digest::MD5';
 requires 'Data::Dumper';
@@ -26,6 +28,7 @@ requires 'Mojo::Base';
 requires 'Mojo::IOLoop';
 requires 'Mojo::UserAgent';
 requires 'Mojo::UserAgent::Cached';
+requires 'String::Random';
 requires 'Text::Fuzzy';
 requires 'URI::Encode::XS';
 requires 'URI::URL';
--- a/data/archeologic_artifacts.txt
+++ b/data/archeologic_artifacts.txt
@@ -0,0 +1,54 @@
+амулет Мерлина
+библиотеку Ивана Грозного
+деревянную плошку
+диплока
+доски Ноева Ковчега
+древний презерватив из бараньей кишки
+икону
+инсталятор Windows 3.11
+истлевший гроб
+каменный топор
+клад со златом-серебром
+кривой нож
+ледяную глыбу
+лунный грунт
+мамонта
+мамонтёнка
+метеорит
+мумию фараона Тутанхамона
+носки прапорщика (поставит в угол)
+обломки грузинской керамики
+птеродактиля
+рубль с Лениным
+рыцарские доспехи
+синий мох
+скелет
+скелет собаки по кличке Беня
+тиранозавтра
+тотем индейцев
+трубу с туркменским газом
+скорбь еврейского народа
+залежи активированного угля
+не очень новый завет
+мать леннарта поттеринга
+руководство "начинающему археологу"
+слово о полку игореве и дело о полку игореве, вместе с игорем
+телепрограмму канала A-one
+могилу искателя могил
+заплесневевший кусок хлеба
+преемник радиоприемника
+глушитель от ВАЗ-2106
+чувство удовлетворения
+крота
+воспоминания о былой любви
+грязистор
+египетское мумиё
+окаменелый камень
+кладку яиц рептилоида
+яму
+чеснок и стрелы
+доллар по 30
+несмазанные скрижали
+четырелобита
+чучело тролля
+целое ничего
--- a/data/fisher_artifacts.txt
+++ b/data/fisher_artifacts.txt
@@ -0,0 +1,47 @@
+семикрылого чешуйчатого пятихуя
+разумного конденсатора
+сальмонеллу
+селёдку
+желтоперого тунца
+розовую сальмонеллу
+голавля
+барбуса
+окуня
+верхоплавку
+коричневую форель
+полярника
+плотву
+зубатку
+солнечную рыбу
+старую шину
+скользкую корягу
+лампу джина
+любовное послание в бутылке
+старое бревно
+резиновый сапог
+труп
+Лох-Несское чудовище
+старую рыбацкую приманку
+кусок Титаника
+обломок Атлантиды
+кита
+кальмара
+дельфина
+ската
+подводную лодку
+медузу
+морскую звезду
+электрического угря
+большую белую акулу
+аквалангиста
+монстра
+вируса
+сырую пачку сигарет
+водоросли
+якорь от лодки
+водяного
+русалку
+палтуса
+труп собаки по кличке Беня
+олигофрена Проню
+огеймера Фишкина
--- a/data/sample_config.json
+++ b/data/sample_config.json
@@ -2,6 +2,11 @@
    # Cachedir used not only for caches but for some settings and stats too.
    "cachedir" : "data/cache",

+    "gamestat" : {
+        "dir" : "data",
+        "gamestatdir" : "data/gamestat"
+    },
+
    "fortune" : {
        "dir" : "data/fortune",
        "srcdir" : "data/fortune_src"
--- a/lib/BotLib/Archeologist.pm
+++ b/lib/BotLib/Archeologist.pm
@@ -6,72 +6,53 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
+use DBI;
+use Log::Any qw ($log);
 use Math::Random::Secure qw (irand);

+use BotLib::Conf qw (LoadConf);
+
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
 our @EXPORT_OK = qw (Dig);

+my $c = LoadConf ();
+my $gamestatdir = $c->{gamestat}->{gamestatdir};
+my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
+
+
+sub getRandomArtifact {
+	my $dbh;
+	$dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->{sqlite_unicode} = 1;
+
+	my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 0 AND id < 10000') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr);
+
+	return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0];
+}
+
 sub Dig {
 	my $name = shift;

-	my @artifact = (
-		'амулет Мерлина',
-		'библиотеку Ивана Грозного',
-		'деревянную плошку',
-		'диплока',
-		'доски Ноева Ковчега',
-		'древний презерватив из бараньей кишки',
-		'икону',
-		'инсталятор Windows 3.11',
-		'истлевший гроб',
-		'каменный топор',
-		'клад со златом-серебром',
-		'кривой нож',
-		'ледяную глыбу',
-		'лунный грунт',
-		'мамонта',
-		'мамонтёнка',
-		'метеорит',
-		'мумию фараона Тутанхамона',
-		'носки прапорщика (поставит в угол)',
-		'обломки грузинской керамики',
-		'птеродактиля',
-		'рубль с Лениным',
-		'рыцарские доспехи',
-		'синий мох',
-		'скелет',
-		'скелет собаки по кличке Беня',
-		'тиранозавтра',
-		'тотем индейцев',
-		'трубу с туркменским газом',
-		'скорбь еврейского народа',
-		'залежи активированного угля',
-		'не очень новый завет',
-		'мать леннарта поттеринга',
-		'руководство "начинающему археологу"',
-		'слово о полку игореве и дело о полку игореве, вместе с игорем',
-		'телепрограмму канала A-one',
-		'могилу искателя могил',
-		'заплесневевший кусок хлеба',
-		'преемник радиоприемника',
-		'глушитель от ВАЗ-2106',
-		'чувство удовлетворения',
-		'крота',
-		'воспоминания о былой любви',
-		'грязистор',
-		'египетское мумиё',
-		'окаменелый камень',
-		'кладку яиц рептилоида',
-		'яму',
-		'чеснок и стрелы',
-		'доллар по 30',
-		'несмазанные скрижали',
-		'четырелобита',
-		'чучело тролля',
-		'целое ничего',
-	);
-
 	my @location = (
 		'в архивах',
 		'в гималаях',
@@ -110,11 +91,12 @@ sub Dig {

 	my $phrase = sprintf "Вы начали раскопки %s и усиленно роете лопатами, экскаватором...\n", $location[irand ($#location + 1)];
 	$phrase .= "Вам кажется что ваш совочек ударился обо что-то твердое. Может, это клад?!\n\n";
+	my $artifact = getRandomArtifact();

 	if ($success_probability <= 25) {
-		$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact[irand ($#artifact + 1)], $artifact_age;
+		$phrase .= sprintf '%s стал лучшим археологом, выкопав %s! возраст артефакта - %s лет!', $name, $artifact, $artifact_age;
 	} else {
-		$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact[irand ($#artifact + 1)], $artifact_age;
+		$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact, $artifact_age;
 		$phrase .= sprintf 'Извини, %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
 	}

--- a/lib/BotLib/Fisher.pm
+++ b/lib/BotLib/Fisher.pm
@@ -6,66 +6,54 @@ use warnings;
 use utf8;
 use open qw (:std :utf8);
 use English qw ( -no_match_vars );
+use DBI;
+use Log::Any qw ($log);
 use Math::Random::Secure qw (irand);

+use BotLib::Conf qw (LoadConf);
+
 use version; our $VERSION = qw (1.0);
 use Exporter qw (import);
 our @EXPORT_OK = qw (Fish);

+my $c = LoadConf ();
+my $gamestatdir = $c->{gamestat}->{gamestatdir};
+my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
+
+
+sub getRandomArtifact {
+	my $dbh;
+	$dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->{sqlite_unicode} = 1;
+
+	my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	my $ary_ref = $dbh->selectall_arrayref ('SELECT name FROM artifacts WHERE id > 9999 AND id < 20000') or do {
+		$log->error (sprintf '[ERROR] Unable to get random artifact, sqlite error: %s', $dbh->errstr);
+		return undef;
+	};
+
+	$dbh->disconnect or $log->warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr);
+
+	return $ary_ref->[irand ($#{ $ary_ref } + 1)]->[0];
+}
+

 sub Fish {
 	my $name = shift;

-	my @artifact = (
-		'семикрылого чешуйчатого пятихуя',
-		'разумного конденсатора',
-		'сальмонеллу',
-		'селёдку',
-		'желтоперого тунца',
-		'розовую сальмонеллу',
-		'голавля',
-		'барбуса',
-		'окуня',
-		'верхоплавку',
-		'коричневую форель',
-		'полярника',
-		'плотву',
-		'зубатку',
-		'солнечную рыбу',
-		'старую шину',
-		'скользкую корягу',
-		'лампу джина',
-		'любовное послание в бутылке',
-		'старое бревно',
-		'резиновый сапог',
-		'труп',
-		'Лох-Несское чудовище',
-		'старую рыбацкую приманку',
-		'кусок Титаника',
-		'обломок Атлантиды',
-		'кита',
-		'кальмара',
-		'дельфина',
-		'ската',
-		'подводную лодку',
-		'медузу',
-		'морскую звезду',
-		'электрического угря',
-		'большую белую акулу',
-		'аквалангиста',
-		'монстра',
-		'вируса',
-		'сырую пачку сигарет',
-		'водоросли',
-		'якорь от лодки',
-		'водяного',
-		'русалку',
-		'палтуса',
-		'труп собаки по кличке Беня',
-		'олигофрена Проню',
-		'огеймера Фишкина',
-	);
-
 	my @location = (
 		'в поток',
 		'в озеро',
@@ -117,7 +105,8 @@ sub Fish {
 		return $phrase;
 	}

-	$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact[irand ($#artifact + 1)], $weight;
+	my $artifact = getRandomArtifact ();
+	$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact, $weight;

 	if ($success_probability <= 25) {
 		$phrase .= sprintf 'Ё-мое!!! А это ведь новый рекорд! Продолжай в том же духе, %s!', $name;
--- a/lib/BotLib/Gamestat.pm
+++ b/lib/BotLib/Gamestat.pm
@@ -0,0 +1,116 @@
+package BotLib::Gamestat;
+# Stores and calculates player stats for games
+
+use 5.018;
+use strict;
+use warnings;
+use utf8;
+use open qw (:std :utf8);
+use DBI;
+use English qw ( -no_match_vars );
+use File::Path qw (make_path);
+use String::Random qw (random_string);
+
+use BotLib::Conf qw (LoadConf);
+use BotLib::Util qw (trim utf2sha1);
+
+use version; our $VERSION = qw (1.0);
+use Exporter qw (import);
+our @EXPORT_OK = qw (SeedArtifacts);
+
+
+my $c = LoadConf ();
+my $dir = $c->{gamestat}->{dir};
+my $gamestatdir = $c->{gamestat}->{gamestatdir};
+my $dbfile = sprintf '%s/gamestat.sqlite', $gamestatdir;
+
+# assume that there is not too much artifacts.
+sub SeedArtifacts {
+	open (my $AFH, '<', "$dir/archeologic_artifacts.txt") || die "No $dir/archeologic_artifacts.txt";
+	my @arch_artifacts;
+
+	while (my $artifact = <$AFH>) {
+		next if ($artifact =~ /^\s*$/);
+		$artifact = trim ($artifact);
+		push @arch_artifacts, $artifact;
+	}
+
+	close $AFH;
+
+	open ($AFH, '<', "$dir/fisher_artifacts.txt") || die "No $dir/fisher_artifacts.txt";
+	my @fisher_artifacts;
+
+	while (my $artifact = <$AFH>) {
+		next if ($artifact =~ /^\s*$/);
+		$artifact = trim ($artifact);
+		push @fisher_artifacts, $artifact;
+	}
+
+	close $AFH;
+	undef $AFH;
+
+	my $tablename = random_string ("..........");
+	$tablename = utf2sha1 ($tablename);
+
+	while ($tablename =~ /^\d/) {
+		$tablename = utf2sha1 ($tablename);
+	}
+
+	$tablename =~ s/[\/_\+]/a/g;
+	$tablename = lc ($tablename);
+
+	unless (-d $gamestatdir) {
+		make_path ($gamestatdir)  ||  die "Unable to create $dir: $OS_ERROR";
+	}
+
+	my $dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '');
+	$dbh->{sqlite_unicode} = 1;
+	my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or die $dbh->errstr;
+	$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or die $dbh->errstr;
+
+	# Open transaction
+	$dbh->begin_work or die $dbh->errstr;
+
+	$rows_affected = $dbh->do (
+		qq {
+			CREATE TABLE IF NOT EXISTS $tablename (
+				id INT UNIQUE NOT NULL, -- artifact id
+				name TEXT PRIMARY KEY   -- artifact name
+			);
+		}
+	) or die $dbh->errstr;
+
+	my $sth = $dbh->prepare ("REPLACE INTO $tablename(id,name) VALUES (?,?)") or die $dbh->errstr;
+
+	# Insert our archeological artifacts
+	my $c = 0;
+
+	foreach my $artifact (@arch_artifacts) {
+		last if ($c == 10000);
+		$sth->execute ($c, $artifact);
+		$c++;
+	}
+
+	# Insert our fishing artifacts
+	$c = 10000;
+
+	foreach my $artifact (@fisher_artifacts) {
+		last if ($c == 20000);
+		$sth->execute ($c, $artifact);
+		$c++;
+	}
+
+	# Add indexes
+	$rows_affected = $dbh->do ("CREATE INDEX IF NOT EXISTS myartifactid ON $tablename(id)") or die $dbh->errstr;
+
+	# Drop target table and replace it with our
+	$rows_affected = $dbh->do ("DROP TABLE IF EXISTS artifacts") or die $dbh->errstr;
+	$rows_affected = $dbh->do ("ALTER TABLE $tablename RENAME TO artifacts") or die $dbh->errstr;
+
+	# Close transaction
+	$dbh->commit or die $dbh->errstr;
+	$dbh->disconnect or warn (sprintf '[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr);
+	return;
+}
+
+1;