Add caching to naodash_user
[nethack-naodash.git] / lib / NetHack / NAOdash.pm
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
9 our $VERSION = '0.001';
10 our @EXPORT_OK = qw/naodash_xlog naodash_user/;
11 our @EXPORT = @EXPORT_OK;
12
13 use File::Slurp;
14 use File::Spec::Functions qw/tmpdir catdir catfile/;
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
116 sub _get_xlog_from_server {
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};
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;
129 write_file $file, _get_xlog_from_server $name unless -f $file && time - (stat $file)[9] < 86400;
130 scalar read_file $file
131 }
132
133 sub naodash_user {
134 my ($name) = @_;
135 my $xlog = _get_xlog $name;
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
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
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
This page took 0.037584 seconds and 4 git commands to generate.