Add caching to naodash_user
[nethack-naodash.git] / lib / NetHack / NAOdash.pm
CommitLineData
01ba3ddc
MG
1package NetHack::NAOdash;
2
3use 5.014000;
4use strict;
5use warnings;
6use re '/saa';
7use parent qw/Exporter/;
8
9our $VERSION = '0.001';
10our @EXPORT_OK = qw/naodash_xlog naodash_user/;
11our @EXPORT = @EXPORT_OK;
12
49bfce9d
MG
13use File::Slurp;
14use File::Spec::Functions qw/tmpdir catdir catfile/;
01ba3ddc
MG
15use HTTP::Tiny;
16use List::Util qw/max min sum/;
17use List::MoreUtils qw/uniq/;
18use Text::XLogfile qw/parse_xlogline/;
19
20sub won_game {
21 my %game = @_;
22 $game{death} eq 'ascended'
23}
24
25our @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
57our %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
69sub 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
78our %max_subs = (
79 maxhp => make_attr_sub 'maxhp',
80 maxpoints => make_attr_sub 'points',
81 maxconducts => make_attr_sub 'nconducts',
82);
83
84our %min_subs = (
85 minturns => make_attr_sub 'turns',
86 minrealtime => make_attr_sub 'realtime',
87);
88
89sub 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
114my $ht = HTTP::Tiny->new(agent => "NetHack-NAOdash/$VERSION ");
115
49bfce9d 116sub _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
123sub _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;
129 write_file $file, _get_xlog_from_server $name unless -f $file && time - (stat $file)[9] < 86400;
130 scalar read_file $file
131}
132
133sub 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
1401;
141__END__
142
143=encoding utf-8
144
145=head1 NAME
146
147NetHack::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
168NetHack::NAOdash analyzes a NetHack xlogfile and reports statistics.
169There are two types of statistics: B<checks>, which are flags
170(booleans) and B<numbers> which are integers.
171
172The B<checks> are tracked across all games. That is, a B<check> will
173be true in the statistics if it is true in at least one game. Except
174for B<checks> in the I<Achievements> category, only games that end in
175an ascension are considered for awarding a B<check>.
176
177The B<checks>, sorted by category, are:
178
179=over
180
181=item B<Achievements>
182
183These start with C<achieve_> and represent significant milestones in a
184game. They are usually relevant only for users who never ascended, as
185a 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
193These look like C<combo_role_race_alignment> and represent
194role/race/alignment combinations in ascended games. The starting
195alignment, not the alignment at the end of the game is considered. For
196example, C<cav_gno_neu> is true if the user ascended at least one
197gnomish caveman.
198
199=item B<Conducts>
200
201These start with C<conduct_> and represent the 12 officially tracked
202conducts.
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
211These start with C<uconduct_> and represent conducts that are not
212officially tracked by the game.
213
214 uconduct_survivor uconduct_bones uconduct_minscore
215
216=back
217
218The numbers are:
219
220=over
221
222=item B<totalrealtime>
223
224The total time spent playing NetHack on NAO, in seconds.
225
226=item B<games>
227
228The number of games played.
229
230=item B<ascensions>
231
232The number of games played that ended in an ascension.
233
234=item B<maxhp>
235
236The highest maxHP at the end of an ascension.
237
238=item B<maxpoints>
239
240The highest score obtained at the end of an ascension.
241
242=item B<maxconducts>
243
244The maximum number of conducts at the end of an ascension.
245
246=item B<minturns>
247
248The minimum turns across ascended games.
249
250=item B<minrealtime>
251
252The minimum realtime across ascended games, in seconds.
253
254=back
255
256This module exports two functions:
257
258=over
259
260=item B<naodash_xlog>(I<@lines>)
261
262=item B<naodash_xlog>(I<$xlog>)
263
264Takes the contents of an xlogfile and returns the results of the
265analysis. The arguments are joined together then split by the newline
266character, so they can be specified as a single string, as a list of
267lines, or as a combination thereof.
268
269The return value is of the following form:
270
271 { checks => ['achieve_sokoban', 'achieve_luckstone', ...],
272 numbers => {totalrealtime => 12345, games => 2, ...} }
273
274In other words, C<< @{$result->{checks}} >> is an array of B<checks>
275that are true and C<< %{$result->{numbers}} >> is a hash of
276B<numbers>.
277
278=item B<naodash_user>(I<$nao_username>)
279
280Retrieves the xlogfile of a user from NAO and gives it to
281B<naodash_xlog>. Dies if no xlogfile is found or if the server cannot
282be contacted.
283
49bfce9d
MG
284This method caches the downloaded xlogfiles for one day in the
285directory named by the NAODASH_CACHE environment variable.
286
287=back
288
289=head1 ENVIRONMENT
290
291=over
292
293=item NAODASH_CACHE
294
295Path to a directory that should be used to cache xlogfiles downloaded
296from NAO, or the special value 'none' (case-insensitive) to disable
297caching.
298
299By default a directory named 'naodash' in the default temporary
300directory (C<< File::Spec->tmpdir >>) is used.
301
01ba3ddc
MG
302=back
303
304=head1 SEE ALSO
305
306L<App::NAOdash>, L<App::Web::NAOdash>, L<http://alt.org/nethack/>
307
308=head1 AUTHOR
309
310Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
311
312=head1 COPYRIGHT AND LICENSE
313
314Copyright (C) 2015 by Marius Gavrilescu
315
316This library is free software; you can redistribute it and/or modify
317it under the same terms as Perl itself, either Perl version 5.20.2 or,
318at your option, any later version of Perl 5 you may have available.
319
320
321=cut
This page took 0.027345 seconds and 4 git commands to generate.