Initial commit
This commit is contained in:
eleksir
108
lib/Games/Archeologist.pm
Normal file
108
lib/Games/Archeologist.pm
Normal file
@@ -0,0 +1,108 @@
|
||||
package Games::Archeologist;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
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 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 @location = (
|
||||
'в архивах',
|
||||
'в гималаях',
|
||||
'в интернете',
|
||||
'в кармане',
|
||||
'в клумбе',
|
||||
'в лунном кратере',
|
||||
'во льдах арктики',
|
||||
'в морге',
|
||||
'в окрестностях погоста',
|
||||
'в песочнице',
|
||||
'в пустыне Гоби',
|
||||
'в пустыне Сахаре',
|
||||
'в русле высохшей реки',
|
||||
'в собственной памяти',
|
||||
'в старом сортире',
|
||||
'в углу',
|
||||
'в цветочном горшке',
|
||||
'на бабушкином огороде',
|
||||
'на винчестере',
|
||||
'на горе Арарат',
|
||||
'на горном плато',
|
||||
'на дне моря',
|
||||
'на необитаемом острове',
|
||||
'на первом слое сумрака',
|
||||
'на просторах Украины',
|
||||
);
|
||||
|
||||
my $find_probability = irand 100;
|
||||
my $success_probability = irand 100;
|
||||
my $artifact_age = irand 15000;
|
||||
|
||||
if ($find_probability <= 20) {
|
||||
return sprintf 'По уши закопавшись %s, %s, нифига вы не выкопали! Может повезет в другом месте?', $location[irand ($#location + 1)], $name;
|
||||
}
|
||||
|
||||
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, $artifact_age;
|
||||
} else {
|
||||
$phrase .= sprintf "Поздравляю, %s! Вы только что выкопали %s, возраст - %s лет!\n", $name, $artifact, $artifact_age;
|
||||
$phrase .= sprintf 'Извини, %s, но на артефакт это не тянет! Однако, попытка хорошая!', $name;
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
122
lib/Games/Fisher.pm
Normal file
122
lib/Games/Fisher.pm
Normal file
@@ -0,0 +1,122 @@
|
||||
package Games::Fisher;
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
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 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 @location = (
|
||||
'в поток',
|
||||
'в озеро',
|
||||
'в реку',
|
||||
'в северный ледовитый океан',
|
||||
'в индийский океан',
|
||||
'в биде',
|
||||
'в детский плавательный бассейн',
|
||||
'в туалет',
|
||||
'в кучу рвоты',
|
||||
'в лужу мочи',
|
||||
'в раковину',
|
||||
'в слив ванной',
|
||||
'в лужу грязи',
|
||||
'в ведро воды',
|
||||
'в бутылку с водкой',
|
||||
'в ванную',
|
||||
'в бочку с дождевой водой',
|
||||
'в аквариум',
|
||||
'в сугроб',
|
||||
'в водопад',
|
||||
'в чашку кофе',
|
||||
'в стакан молока',
|
||||
'в черную дыру',
|
||||
'дно Удомельского реактора',
|
||||
'на Марс',
|
||||
'в соседнюю галактику',
|
||||
'к соседу на балкон',
|
||||
'далеко-далеко',
|
||||
'далеко и надолго',
|
||||
'на крышу дома',
|
||||
);
|
||||
|
||||
my @material = (
|
||||
'бамбуковую',
|
||||
'фибергласовую',
|
||||
'карбоновую',
|
||||
'композитную',
|
||||
);
|
||||
|
||||
my $find_probability = irand 100;
|
||||
my $success_probability = irand 100;
|
||||
my $weight = irand 7000;
|
||||
|
||||
my $phrase = sprintf "Вы забрасываете %s удочку %s.\nВы чувствуете поклёвку и начинаете быстро тащить что-то.\n", $material[irand ($#material + 1)], $location[irand ($#location + 1)];
|
||||
|
||||
if ($find_probability <= 20) {
|
||||
$phrase .= sprintf 'Черт, твоя рыбка сорвалась, %s! Не беда, может потом повезет?', $name;
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
my $artifact = getRandomArtifact ();
|
||||
$phrase .= sprintf "Поздравляю, %s! Вы только что поймали %s! аж на %d кило!\n\n", $name, $artifact, $weight;
|
||||
|
||||
if ($success_probability <= 25) {
|
||||
$phrase .= sprintf 'Ё-мое!!! А это ведь новый рекорд! Продолжай в том же духе, %s!', $name;
|
||||
} else {
|
||||
$phrase .= sprintf 'Извини, %s, но это не новый рекорд! Однако, хорошая попытка!', $name;
|
||||
}
|
||||
|
||||
return $phrase;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
116
lib/Games/Gamestat.pm
Normal file
116
lib/Games/Gamestat.pm
Normal file
@@ -0,0 +1,116 @@
|
||||
package Games::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 Mojo::Util qw (trim);
|
||||
use String::Random qw (random_string);
|
||||
|
||||
use Conf qw (LoadConf);
|
||||
use Util qw (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\n";
|
||||
my @arch_artifacts;
|
||||
|
||||
while (my $artifact = <$AFH>) {
|
||||
next if ($artifact =~ /^\s*$/s);
|
||||
$artifact = trim ($artifact);
|
||||
push @arch_artifacts, $artifact;
|
||||
}
|
||||
|
||||
close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
|
||||
open ($AFH, '<', "$dir/fisher_artifacts.txt") || die "No $dir/fisher_artifacts.txt\n";
|
||||
my @fisher_artifacts;
|
||||
|
||||
while (my $artifact = <$AFH>) {
|
||||
next if ($artifact =~ /^\s*$/s);
|
||||
$artifact = trim ($artifact);
|
||||
push @fisher_artifacts, $artifact;
|
||||
}
|
||||
|
||||
close $AFH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
undef $AFH;
|
||||
|
||||
my $tablename = random_string ('..........');
|
||||
$tablename = utf2sha1 ($tablename);
|
||||
|
||||
while ($tablename =~ /^\d/s) {
|
||||
$tablename = utf2sha1 ($tablename);
|
||||
}
|
||||
|
||||
$tablename =~ s/[\/_\+]/a/sg;
|
||||
$tablename = lc $tablename;
|
||||
|
||||
unless (-d $gamestatdir) {
|
||||
make_path ($gamestatdir) || die "Unable to create $gamestatdir: $OS_ERROR\n";
|
||||
}
|
||||
|
||||
my $dbh = DBI->connect ("dbi:SQLite:$dbfile", '', '');
|
||||
$dbh->{sqlite_unicode} = 1;
|
||||
my $rows_affected = $dbh->do ('PRAGMA foreign_keys=ON') or die $dbh->errstr . "\n";
|
||||
$rows_affected = $dbh->do ('PRAGMA journal_mode=WAL') or die $dbh->errstr . "\n";
|
||||
|
||||
# Open transaction
|
||||
$dbh->begin_work or die $dbh->errstr . "\n";
|
||||
|
||||
my $query = <<"QUERY";
|
||||
CREATE TABLE IF NOT EXISTS $tablename (
|
||||
id INT UNIQUE NOT NULL, -- artifact id
|
||||
name TEXT PRIMARY KEY -- artifact name
|
||||
);
|
||||
QUERY
|
||||
|
||||
$rows_affected = $dbh->do ($query) or die $dbh->errstr . "\n";
|
||||
my $sth = $dbh->prepare ("REPLACE INTO $tablename(id,name) VALUES (?,?)") or die $dbh->errstr . "\n";
|
||||
|
||||
# Insert our archeological artifacts
|
||||
my $counter = 0;
|
||||
|
||||
foreach my $artifact (@arch_artifacts) {
|
||||
last if ($counter == 10000);
|
||||
$sth->execute ($counter, $artifact);
|
||||
$counter++;
|
||||
}
|
||||
|
||||
# Insert our fishing artifacts
|
||||
$counter = 10000;
|
||||
|
||||
foreach my $artifact (@fisher_artifacts) {
|
||||
last if ($counter == 20000);
|
||||
$sth->execute ($counter, $artifact);
|
||||
$counter++;
|
||||
}
|
||||
|
||||
# Add indexes
|
||||
$rows_affected = $dbh->do ("CREATE INDEX IF NOT EXISTS myartifactid ON $tablename(id)") or die $dbh->errstr . "\n";
|
||||
|
||||
# Drop target table and replace it with our
|
||||
$rows_affected = $dbh->do ('DROP TABLE IF EXISTS artifacts') or die $dbh->errstr . "\n";
|
||||
$rows_affected = $dbh->do ("ALTER TABLE $tablename RENAME TO artifacts") or die $dbh->errstr . "\n";
|
||||
|
||||
# Close transaction
|
||||
$dbh->commit or die $dbh->errstr . "\n";
|
||||
$dbh->disconnect or warn sprintf ('[WARN] Unable to close gamestat db, sqlite error: %s', $dbh->errstr) . "\n";
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user