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