[nethack-naodash.git] / lib / NetHack / NAOdash.pm

package NetHack::NAOdash;

use 5.014000;
use strict;
use warnings;
use re '/saa';
use parent qw/Exporter/;

our $VERSION = '0.002';
our @EXPORT_OK = qw/naodash_xlog naodash_user/;
our @EXPORT = @EXPORT_OK;

use File::Slurp;
use File::Spec::Functions qw/tmpdir catdir catfile/;
use HTTP::Tiny;
use List::Util qw/max min sum/;
use List::MoreUtils qw/uniq/;
use Text::XLogfile qw/parse_xlogline/;

sub won_game {
	my %game = @_;
	$game{death} eq 'ascended'
}

our @check_subs = (
	sub { # Combos
		my %game = @_;
		return unless won_game %game;
		$game{align0} //= $game{align};
		"combo_$game{role}_$game{race}_$game{align0}"
	},

	sub { # Achievements
		my %game = @_;
		my @achieves = qw/bell gehennom candelabrum book invocation amulet endgame astral ascended luckstone sokoban medusa/;
		map { $game{achieve} & (1 << $_) ? "achieve_$achieves[$_]" : () } 0 .. $#achieves
	},

	sub { # Conducts
		my %game = @_;
		return unless won_game %game;
		my @conducts = qw/foodless vegan vegetarian atheist weaponless pacifist illiterate polypileless polyselfless wishless artiwishless genocideless/;
		map { $game{conduct} & (1 << $_) ? "conduct_$conducts[$_]" : () } 0 .. $#conducts
	},

	sub { # Unofficial conducts
		my %game = @_;
		return unless won_game %game;
		my @uconducts;
		push @uconducts, 'survivor' if $game{deaths} == 0;
		push @uconducts, 'boneless' unless $game{flags} & 32;
		push @uconducts, 'minscore' if $game{points} - 100 * ($game{maxlvl} - 45) == 24_400;
		map { "uconduct_$_" } @uconducts
	},
);

our %sum_subs = (
	games => sub { 1 },
	ascensions => sub {
		my %game = @_;
		!!won_game %game
	},
	totalrealtime => sub {
		my %game = @_;
		$game{realtime} // 0
	},
);

sub make_attr_sub ($) { ## no critic (ProhibitSubroutinePrototypes)
	my ($attr) = @_;
	sub {
		my %game = @_;
		return unless won_game %game;
		$game{$attr} // ()
	},
}

our %max_subs = (
	maxhp => make_attr_sub 'maxhp',
	maxpoints => make_attr_sub 'points',
	maxconducts => make_attr_sub 'nconducts',
);

our %min_subs = (
	minturns => make_attr_sub 'turns',
	minrealtime => make_attr_sub 'realtime',
);

sub naodash_xlog { ## no critic (RequireArgUnpacking)
	my ($xlog) = join '', @_;
	my %number_subs = (%sum_subs, %max_subs, %min_subs);

	my @checks;
	my %numbers = map { $_ => [] } keys %number_subs;

	for my $logline (split /\n/, $xlog) {
		my %game = %{parse_xlogline $logline};
		for (keys %game) {
			delete $game{$_} if $game{$_} eq ''
		}
		next if $game{flags} & 3; # flag 0x01 is wizard mode, 0x02 is explore mode
		push @checks, $_->(%game) for @check_subs;
		push @{$numbers{$_}}, $number_subs{$_}->(%game) for keys %number_subs;
	}

	$numbers{$_} = sum @{$numbers{$_}} for keys %sum_subs;
	$numbers{$_} = max @{$numbers{$_}} for keys %max_subs;
	$numbers{$_} = min @{$numbers{$_}} for keys %min_subs;
	@checks = uniq map { lc } @checks;

	{checks => [sort @checks], numbers => \%numbers}
}

my $ht = HTTP::Tiny->new(agent => "NetHack-NAOdash/$VERSION ");

sub _get_xlog_from_server {
	my ($name) = @_;
	my $ret = $ht->get("http://alt.org/nethack/player-all-xlog.php?player=$name");
	die 'Error while retrieving xlogfile from alt.org: ' . $ret->{status} . ' ' . $ret->{reason} . "\n" unless $ret->{success};
	$ret->{content} =~ m{<pre>(.*)</pre>}i;
}

sub _get_xlog {
	my ($name) = @_;
	return _get_xlog_from_server $name if $ENV{NAODASH_CACHE} && lc $ENV{NAODASH_CACHE} eq 'none';
	my $dir = $ENV{NAODASH_CACHE} || catdir tmpdir, 'naodash';
	mkdir $dir or die "Cannot create cache directory: $!\n" unless -d $dir;
	my $file = catfile $dir, $name;
	write_file $file, _get_xlog_from_server $name if ! -f $file || time - (stat $file)[9] >= 86_400;
	scalar read_file $file
}

sub naodash_user {
	my ($name) = @_;
	my $xlog = _get_xlog $name;
	die "No xlogfile found for user $name\n" unless defined $xlog;
	naodash_xlog $xlog;
}

1;
__END__

=encoding utf-8

=head1 NAME

NetHack::NAOdash - Analyze NetHack xlogfiles and extract statistics

=head1 SYNOPSIS

  use NetHack::NAOdash;
  my $stats = naodash_user 'mgv'; # Retrieve and analyze mgv's xlogfile from alt.org
  my @checks = @{$stats->{checks}}; # List of "achievements" obtained by mgv
  my %checks = map { $_ => 1 } @checks;
  say "mgv has ascended an orcish rogue" if $checks{combo_rog_orc_cha};
  say "mgv has ascended an atheist character" if $checks{conduct_atheist};
  my %numbers = %{$stats->{numbers}};
  say "mgv has ascended $numbers{ascensions} out of $numbers{games} games";
  say "mgv has spent $numbers{totalrealtime} seconds playing NetHack on NAO";

  use File::Slurp;
  $stats = naodash_xlog read_file 'path/to/my/xlogfile';
  %checks = map { $_ => 1 } @{$stats->{checks}};
  say "I have ascended a survivor" if $checks{uconduct_survivor};

=head1 DESCRIPTION

NetHack::NAOdash analyzes a NetHack xlogfile and reports statistics.
There are two types of statistics: B<checks>, which are flags
(booleans) and B<numbers> which are integers.

The B<checks> are tracked across all games. That is, a B<check> will
be true in the statistics if it is true in at least one game. Except
for B<checks> in the I<Achievements> category, only games that end in
an ascension are considered for awarding a B<check>.

The B<checks>, sorted by category, are:

=over

=item B<Achievements>

These start with C<achieve_> and represent significant milestones in a
game. They are usually relevant only for users who never ascended, as
a game that ends in an ascension generally meets all of them.

  achieve_sokoban  achieve_luckstone   achieve_medusa achieve_bell
  achieve_gehennom achieve_candelabrum achieve_book   achieve_invocation
  achieve_amulet   achieve_endgame     achieve_astral achieve_ascended

=item B<Starting Combos>

These look like C<combo_role_race_alignment> and represent
role/race/alignment combinations in ascended games. The starting
alignment, not the alignment at the end of the game is considered. For
example, C<cav_gno_neu> is true if the user ascended at least one
gnomish caveman.

=item B<Conducts>

These start with C<conduct_> and represent the 12 officially tracked
conducts.

  conduct_foodless     conduct_vegan        conduct_vegetarian
  conduct_atheist      conduct_weaponless   conduct_pacifist
  conduct_illiterate   conduct_genocideless conduct_polypileless
  conduct_polyselfless conduct_wishless     conduct_artiwishless

=item B<Unofficial Conducts>

These start with C<uconduct_> and represent conducts that are not
officially tracked by the game.

  uconduct_survivor uconduct_bones uconduct_minscore

=back

The numbers are:

=over

=item B<totalrealtime>

The total time spent playing NetHack on NAO, in seconds.

=item B<games>

The number of games played.

=item B<ascensions>

The number of games played that ended in an ascension.

=item B<maxhp>

The highest maxHP at the end of an ascension.

=item B<maxpoints>

The highest score obtained at the end of an ascension.

=item B<maxconducts>

The maximum number of conducts at the end of an ascension.

=item B<minturns>

The minimum turns across ascended games.

=item B<minrealtime>

The minimum realtime across ascended games, in seconds.

=back

This module exports two functions:

=over

=item B<naodash_xlog>(I<@lines>)

=item B<naodash_xlog>(I<$xlog>)

Takes the contents of an xlogfile and returns the results of the
analysis. The arguments are joined together then split by the newline
character, so they can be specified as a single string, as a list of
lines, or as a combination thereof.

The return value is of the following form:

  { checks => ['achieve_sokoban', 'achieve_luckstone', ...],
    numbers => {totalrealtime => 12345, games => 2, ...} }

In other words, C<< @{$result->{checks}} >> is an array of B<checks>
that are true and C<< %{$result->{numbers}} >> is a hash of
B<numbers>.

=item B<naodash_user>(I<$nao_username>)

Retrieves the xlogfile of a user from NAO and gives it to
B<naodash_xlog>. Dies if no xlogfile is found or if the server cannot
be contacted.

This method caches the downloaded xlogfiles for one day in the
directory named by the NAODASH_CACHE environment variable.

=back

=head1 ENVIRONMENT

=over

=item NAODASH_CACHE

Path to a directory that should be used to cache xlogfiles downloaded
from NAO, or the special value 'none' (case-insensitive) to disable
caching.

By default a directory named 'naodash' in the default temporary
directory (C<< File::Spec->tmpdir >>) is used.

=back

=head1 SEE ALSO

L<App::NAOdash>, L<App::Web::NAOdash>, L<http://alt.org/nethack/>

=head1 AUTHOR

Marius Gavrilescu, E<lt>marius@ieval.roE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015 by Marius Gavrilescu

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.20.2 or,
at your option, any later version of Perl 5 you may have available.


=cut
Commit	Line	Data
01ba3ddc MG	1	package NetHack::NAOdash;
	2
	3	use 5.014000;
	4	use strict;
	5	use warnings;
	6	use re '/saa';
	7	use parent qw/Exporter/;
	8
90d9e1ee	9	our $VERSION = '0.002';
01ba3ddc MG	10	our @EXPORT_OK = qw/naodash_xlog naodash_user/;
	11	our @EXPORT = @EXPORT_OK;
	12
49bfce9d MG	13	use File::Slurp;
49bfce9d MG	14	use File::Spec::Functions qw/tmpdir catdir catfile/;
01ba3ddc MG	15	use HTTP::Tiny;
	16	use List::Util qw/max min sum/;
	17	use List::MoreUtils qw/uniq/;
	18	use Text::XLogfile qw/parse_xlogline/;
	19
	20	sub won_game {
	21	my %game = @_;
	22	$game{death} eq 'ascended'
	23	}
	24
	25	our @check_subs = (
	26	sub { # Combos
	27	my %game = @_;
	28	return unless won_game %game;
	29	$game{align0} //= $game{align};
	30	"combo_$game{role}_$game{race}_$game{align0}"
	31	},
	32
	33	sub { # Achievements
	34	my %game = @_;
	35	my @achieves = qw/bell gehennom candelabrum book invocation amulet endgame astral ascended luckstone sokoban medusa/;
	36	map { $game{achieve} & (1 << $_) ? "achieve_$achieves[$_]" : () } 0 .. $#achieves
	37	},
	38
	39	sub { # Conducts
	40	my %game = @_;
	41	return unless won_game %game;
	42	my @conducts = qw/foodless vegan vegetarian atheist weaponless pacifist illiterate polypileless polyselfless wishless artiwishless genocideless/;
	43	map { $game{conduct} & (1 << $_) ? "conduct_$conducts[$_]" : () } 0 .. $#conducts
	44	},
	45
	46	sub { # Unofficial conducts
	47	my %game = @_;
	48	return unless won_game %game;
	49	my @uconducts;
	50	push @uconducts, 'survivor' if $game{deaths} == 0;
	51	push @uconducts, 'boneless' unless $game{flags} & 32;
	52	push @uconducts, 'minscore' if $game{points} - 100 * ($game{maxlvl} - 45) == 24_400;
	53	map { "uconduct_$_" } @uconducts
	54	},
	55	);
	56
	57	our %sum_subs = (
	58	games => sub { 1 },
	59	ascensions => sub {
	60	my %game = @_;
	61	!!won_game %game
	62	},
	63	totalrealtime => sub {
	64	my %game = @_;
	65	$game{realtime} // 0
	66	},
	67	);
	68
	69	sub make_attr_sub ($) { ## no critic (ProhibitSubroutinePrototypes)
	70	my ($attr) = @_;
	71	sub {
	72	my %game = @_;
	73	return unless won_game %game;
	74	$game{$attr} // ()
	75	},
	76	}
	77
	78	our %max_subs = (
79	maxhp => make_attr_sub 'maxhp',
80	maxpoints => make_attr_sub 'points',
81	maxconducts => make_attr_sub 'nconducts',
82	);
83
84	our %min_subs = (
85	minturns => make_attr_sub 'turns',
86	minrealtime => make_attr_sub 'realtime',
87	);
88
89	sub naodash_xlog { ## no critic (RequireArgUnpacking)
90	my ($xlog) = join '', @_;
91	my %number_subs = (%sum_subs, %max_subs, %min_subs);
92
93	my @checks;
94	my %numbers = map { $_ => [] } keys %number_subs;
95
96	for my $logline (split /\n/, $xlog) {
97	my %game = %{parse_xlogline $logline};
98	for (keys %game) {
99	delete $game{$_} if $game{$_} eq ''
100	}
101	next if $game{flags} & 3; # flag 0x01 is wizard mode, 0x02 is explore mode
102	push @checks, $_->(%game) for @check_subs;
103	push @{$numbers{$_}}, $number_subs{$_}->(%game) for keys %number_subs;
104	}
105
106	$numbers{$_} = sum @{$numbers{$_}} for keys %sum_subs;
107	$numbers{$_} = max @{$numbers{$_}} for keys %max_subs;
108	$numbers{$_} = min @{$numbers{$_}} for keys %min_subs;
109	@checks = uniq map { lc } @checks;
110
111	{checks => [sort @checks], numbers => \%numbers}
112	}
113
114	my $ht = HTTP::Tiny->new(agent => "NetHack-NAOdash/$VERSION ");
115
49bfce9d	116	sub _get_xlog_from_server {
01ba3ddc MG	117	my ($name) = @_;
	118	my $ret = $ht->get("http://alt.org/nethack/player-all-xlog.php?player=$name");
	119	die 'Error while retrieving xlogfile from alt.org: ' . $ret->{status} . ' ' . $ret->{reason} . "\n" unless $ret->{success};
49bfce9d MG	120	$ret->{content} =~ m{<pre>(.*)</pre>}i;
	121	}
	122
	123	sub _get_xlog {
	124	my ($name) = @_;
	125	return _get_xlog_from_server $name if $ENV{NAODASH_CACHE} && lc $ENV{NAODASH_CACHE} eq 'none';
	126	my $dir = $ENV{NAODASH_CACHE} \|\| catdir tmpdir, 'naodash';
	127	mkdir $dir or die "Cannot create cache directory: $!\n" unless -d $dir;
	128	my $file = catfile $dir, $name;
3b893b63	129	write_file $file, _get_xlog_from_server $name if ! -f $file \|\| time - (stat $file)[9] >= 86_400;
49bfce9d MG	130	scalar read_file $file
	131	}
	132
	133	sub naodash_user {
	134	my ($name) = @_;
	135	my $xlog = _get_xlog $name;
01ba3ddc MG	136	die "No xlogfile found for user $name\n" unless defined $xlog;
	137	naodash_xlog $xlog;
	138	}
	139
	140	1;
	141	__END__
	142
	143	=encoding utf-8
	144
	145	=head1 NAME
	146
	147	NetHack::NAOdash - Analyze NetHack xlogfiles and extract statistics
	148
	149	=head1 SYNOPSIS
	150
	151	use NetHack::NAOdash;
	152	my $stats = naodash_user 'mgv'; # Retrieve and analyze mgv's xlogfile from alt.org
	153	my @checks = @{$stats->{checks}}; # List of "achievements" obtained by mgv
	154	my %checks = map { $_ => 1 } @checks;
	155	say "mgv has ascended an orcish rogue" if $checks{combo_rog_orc_cha};
	156	say "mgv has ascended an atheist character" if $checks{conduct_atheist};
	157	my %numbers = %{$stats->{numbers}};
	158	say "mgv has ascended $numbers{ascensions} out of $numbers{games} games";
	159	say "mgv has spent $numbers{totalrealtime} seconds playing NetHack on NAO";
	160
	161	use File::Slurp;
	162	$stats = naodash_xlog read_file 'path/to/my/xlogfile';
	163	%checks = map { $_ => 1 } @{$stats->{checks}};
	164	say "I have ascended a survivor" if $checks{uconduct_survivor};
	165
	166	=head1 DESCRIPTION
	167
	168	NetHack::NAOdash analyzes a NetHack xlogfile and reports statistics.
	169	There are two types of statistics: B<checks>, which are flags
	170	(booleans) and B<numbers> which are integers.
	171
	172	The B<checks> are tracked across all games. That is, a B<check> will
	173	be true in the statistics if it is true in at least one game. Except
	174	for B<checks> in the I<Achievements> category, only games that end in
	175	an ascension are considered for awarding a B<check>.
	176
	177	The B<checks>, sorted by category, are:
	178
	179	=over
	180
	181	=item B<Achievements>
	182
	183	These start with C<achieve_> and represent significant milestones in a
	184	game. They are usually relevant only for users who never ascended, as
	185	a game that ends in an ascension generally meets all of them.
	186
	187	achieve_sokoban achieve_luckstone achieve_medusa achieve_bell
	188	achieve_gehennom achieve_candelabrum achieve_book achieve_invocation
	189	achieve_amulet achieve_endgame achieve_astral achieve_ascended
	190
	191	=item B<Starting Combos>
	192
	193	These look like C<combo_role_race_alignment> and represent
	194	role/race/alignment combinations in ascended games. The starting
	195	alignment, not the alignment at the end of the game is considered. For
	196	example, C<cav_gno_neu> is true if the user ascended at least one
	197	gnomish caveman.
	198
	199	=item B<Conducts>
200
201	These start with C<conduct_> and represent the 12 officially tracked
202	conducts.
203
204	conduct_foodless conduct_vegan conduct_vegetarian
205	conduct_atheist conduct_weaponless conduct_pacifist
206	conduct_illiterate conduct_genocideless conduct_polypileless
207	conduct_polyselfless conduct_wishless conduct_artiwishless
208
209	=item B<Unofficial Conducts>
210
211	These start with C<uconduct_> and represent conducts that are not
212	officially tracked by the game.
213
214	uconduct_survivor uconduct_bones uconduct_minscore
215
216	=back
217
218	The numbers are:
219
220	=over
221
222	=item B<totalrealtime>
223
224	The total time spent playing NetHack on NAO, in seconds.
225
226	=item B<games>
227
228	The number of games played.
229
230	=item B<ascensions>
231
232	The number of games played that ended in an ascension.
233
234	=item B<maxhp>
235
236	The highest maxHP at the end of an ascension.
237
238	=item B<maxpoints>
239
240	The highest score obtained at the end of an ascension.
241
242	=item B<maxconducts>
243
244	The maximum number of conducts at the end of an ascension.
245
246	=item B<minturns>
247
248	The minimum turns across ascended games.
249
250	=item B<minrealtime>
251
252	The minimum realtime across ascended games, in seconds.
253
254	=back
255
256	This module exports two functions:
257
258	=over
259
260	=item B<naodash_xlog>(I<@lines>)
261
262	=item B<naodash_xlog>(I<$xlog>)
263
264	Takes the contents of an xlogfile and returns the results of the
265	analysis. The arguments are joined together then split by the newline
266	character, so they can be specified as a single string, as a list of
267	lines, or as a combination thereof.
268
269	The return value is of the following form:
270
271	{ checks => ['achieve_sokoban', 'achieve_luckstone', ...],
272	numbers => {totalrealtime => 12345, games => 2, ...} }
273
274	In other words, C<< @{$result->{checks}} >> is an array of B<checks>
275	that are true and C<< %{$result->{numbers}} >> is a hash of
276	B<numbers>.
277
278	=item B<naodash_user>(I<$nao_username>)
279
280	Retrieves the xlogfile of a user from NAO and gives it to
281	B<naodash_xlog>. Dies if no xlogfile is found or if the server cannot
282	be contacted.
283
49bfce9d MG	284	This method caches the downloaded xlogfiles for one day in the
	285	directory named by the NAODASH_CACHE environment variable.
	286
	287	=back
	288
	289	=head1 ENVIRONMENT
	290
	291	=over
	292
	293	=item NAODASH_CACHE
	294
	295	Path to a directory that should be used to cache xlogfiles downloaded
	296	from NAO, or the special value 'none' (case-insensitive) to disable
	297	caching.
	298
	299	By default a directory named 'naodash' in the default temporary
	300	directory (C<< File::Spec->tmpdir >>) is used.
	301
01ba3ddc MG	302	=back
	303
	304	=head1 SEE ALSO
	305
	306	L<App::NAOdash>, L<App::Web::NAOdash>, L<http://alt.org/nethack/>
	307
	308	=head1 AUTHOR
	309
	310	Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
	311
	312	=head1 COPYRIGHT AND LICENSE
	313
	314	Copyright (C) 2015 by Marius Gavrilescu
	315
	316	This library is free software; you can redistribute it and/or modify
	317	it under the same terms as Perl itself, either Perl version 5.20.2 or,
	318	at your option, any later version of Perl 5 you may have available.
	319
	320
	321	=cut