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 if ! -f $file || time - (stat $file)[9] >= 86_400;
 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