From eddbcc62773df7034a7cbe7ed785bebf17ff8e07 Mon Sep 17 00:00:00 2001 From: eleksir Date: Fri, 2 Jul 2021 15:41:21 +0300 Subject: [PATCH] Prep for gamestat implementation * Move artifacts to separate files + Implement db seed with artifacts + Add gamedata_seed.pl script to seed artifacts to db --- .gitignore | 8 ++- bin/gamedata_seed.pl | 26 ++++++++ cpanfile | 3 + data/archeologic_artifacts.txt | 54 +++++++++++++++ data/fisher_artifacts.txt | 47 +++++++++++++ data/sample_config.json | 5 ++ lib/BotLib/Archeologist.pm | 100 ++++++++++++---------------- lib/BotLib/Fisher.pm | 91 ++++++++++++-------------- lib/BotLib/Gamestat.pm | 116 +++++++++++++++++++++++++++++++++ 9 files changed, 337 insertions(+), 113 deletions(-) create mode 100644 bin/gamedata_seed.pl create mode 100644 data/archeologic_artifacts.txt create mode 100644 data/fisher_artifacts.txt create mode 100644 lib/BotLib/Gamestat.pm diff --git a/.gitignore b/.gitignore index a070e34..97beecb 100644 --- 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/** diff --git a/bin/gamedata_seed.pl b/bin/gamedata_seed.pl new file mode 100644 index 0000000..48cfbbe --- /dev/null +++ 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; diff --git a/cpanfile b/cpanfile index 8b61669..3abdba5 100644 --- a/cpanfile +++ b/cpanfile @@ -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'; diff --git a/data/archeologic_artifacts.txt b/data/archeologic_artifacts.txt new file mode 100644 index 0000000..b08628b --- /dev/null +++ b/data/archeologic_artifacts.txt @@ -0,0 +1,54 @@ +амулет Мерлина +библиотеку Ивана Грозного +деревянную плошку +диплока +доски Ноева Ковчега +древний презерватив из бараньей кишки +икону +инсталятор Windows 3.11 +истлевший гроб +каменный топор +клад со златом-серебром +кривой нож +ледяную глыбу +лунный грунт +мамонта +мамонтёнка +метеорит +мумию фараона Тутанхамона +носки прапорщика (поставит в угол) +обломки грузинской керамики +птеродактиля +рубль с Лениным +рыцарские доспехи +синий мох +скелет +скелет собаки по кличке Беня +тиранозавтра +тотем индейцев +трубу с туркменским газом +скорбь еврейского народа +залежи активированного угля +не очень новый завет +мать леннарта поттеринга +руководство "начинающему археологу" +слово о полку игореве и дело о полку игореве, вместе с игорем +телепрограмму канала A-one +могилу искателя могил +заплесневевший кусок хлеба +преемник радиоприемника +глушитель от ВАЗ-2106 +чувство удовлетворения +крота +воспоминания о былой любви +грязистор +египетское мумиё +окаменелый камень +кладку яиц рептилоида +яму +чеснок и стрелы +доллар по 30 +несмазанные скрижали +четырелобита +чучело тролля +целое ничего diff --git a/data/fisher_artifacts.txt b/data/fisher_artifacts.txt new file mode 100644 index 0000000..b2f730c --- /dev/null +++ b/data/fisher_artifacts.txt @@ -0,0 +1,47 @@ +семикрылого чешуйчатого пятихуя +разумного конденсатора +сальмонеллу +селёдку +желтоперого тунца +розовую сальмонеллу +голавля +барбуса +окуня +верхоплавку +коричневую форель +полярника +плотву +зубатку +солнечную рыбу +старую шину +скользкую корягу +лампу джина +любовное послание в бутылке +старое бревно +резиновый сапог +труп +Лох-Несское чудовище +старую рыбацкую приманку +кусок Титаника +обломок Атлантиды +кита +кальмара +дельфина +ската +подводную лодку +медузу +морскую звезду +электрического угря +большую белую акулу +аквалангиста +монстра +вируса +сырую пачку сигарет +водоросли +якорь от лодки +водяного +русалку +палтуса +труп собаки по кличке Беня +олигофрена Проню +огеймера Фишкина diff --git a/data/sample_config.json b/data/sample_config.json index 77bd296..f8380a7 100644 --- 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" diff --git a/lib/BotLib/Archeologist.pm b/lib/BotLib/Archeologist.pm index 3afb0ba..7d4983a 100644 --- 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; } diff --git a/lib/BotLib/Fisher.pm b/lib/BotLib/Fisher.pm index 9264475..4379dbc 100644 --- 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; diff --git a/lib/BotLib/Gamestat.pm b/lib/BotLib/Gamestat.pm new file mode 100644 index 0000000..1b94944 --- /dev/null +++ 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;