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.002';
  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 (%args, %exclude, %include);
  91         %args = %{shift()} if ref $_[0] eq 'HASH'; ## no critic (Builtin)
  92         %exclude = map { $_ => 1 } @{$args{exclude_versions} // []};
  93         %include = map { $_ => 1 } @{$args{include_versions} // []};
  94         my ($xlog) = join '', @_;
  95         my %number_subs = (%sum_subs, %max_subs, %min_subs);
  96
  97         my @checks;
  98         my %numbers = map { $_ => [] } keys %number_subs;
  99
 100         for my $logline (split /\n/, $xlog) {
 101                 my %game = %{parse_xlogline $logline};
 102                 for (keys %game) {
 103                         delete $game{$_} if $game{$_} eq ''
 104                 }
 105                 next if $exclude{$game{version}} || %include && !$include{$game{version}};
 106                 next if $game{flags} & 3; # flag 0x01 is wizard mode, 0x02 is explore mode
 107                 push @checks, $_->(%game) for @check_subs;
 108                 push @{$numbers{$_}}, $number_subs{$_}->(%game) for keys %number_subs;
 109         }
 110
 111         $numbers{$_} = sum @{$numbers{$_}} for keys %sum_subs;
 112         $numbers{$_} = max @{$numbers{$_}} for keys %max_subs;
 113         $numbers{$_} = min @{$numbers{$_}} for keys %min_subs;
 114         @checks = uniq map { lc } @checks;
 115
 116         {checks => [sort @checks], numbers => \%numbers}
 117 }
 118
 119 my $ht = HTTP::Tiny->new(agent => "NetHack-NAOdash/$VERSION ");
 120
 121 sub _get_xlog_from_server {
 122         my ($name) = @_;
 123         my $ret = $ht->get("http://alt.org/nethack/player-all-xlog.php?player=$name");
 124         die 'Error while retrieving xlogfile from alt.org: ' . $ret->{status} . ' ' . $ret->{reason} . "\n" unless $ret->{success};
 125         $ret->{content} =~ m{<pre>(.*)</pre>}i;
 126 }
 127
 128 sub _get_xlog {
 129         my ($name) = @_;
 130         return _get_xlog_from_server $name if $ENV{NAODASH_CACHE} && lc $ENV{NAODASH_CACHE} eq 'none';
 131         my $dir = $ENV{NAODASH_CACHE} || catdir tmpdir, 'naodash';
 132         mkdir $dir or die "Cannot create cache directory: $!\n" unless -d $dir;
 133         my $file = catfile $dir, $name;
 134         write_file $file, _get_xlog_from_server $name if ! -f $file || time - (stat $file)[9] >= 86_400;
 135         scalar read_file $file
 136 }
 137
 138 sub naodash_user { ## no critic (RequireArgUnpacking)
 139         my $args = {};
 140         $args = shift if ref $_[0] eq 'HASH';
 141         my ($name) = @_;
 142         my $xlog = _get_xlog $name;
 143         die "No xlogfile found for user $name\n" unless defined $xlog;
 144         naodash_xlog $args, $xlog;
 145 }
 146
 147 1;
 148 __END__
 149
 150 =encoding utf-8
 151
 152 =head1 NAME
 153
 154 NetHack::NAOdash - Analyze NetHack xlogfiles and extract statistics
 155
 156 =head1 SYNOPSIS
 157
 158   use NetHack::NAOdash;
 159   my $stats = naodash_user 'mgv'; # Retrieve and analyze mgv's xlogfile from alt.org
 160   my @checks = @{$stats->{checks}}; # List of 'achievements' obtained by mgv
 161   my %checks = map { $_ => 1 } @checks;
 162   say 'mgv has ascended an orcish rogue' if $checks{combo_rog_orc_cha};
 163   say 'mgv has ascended an atheist character' if $checks{conduct_atheist};
 164   my %numbers = %{$stats->{numbers}};
 165   say "mgv has ascended $numbers{ascensions} out of $numbers{games} games";
 166   say "mgv has spent $numbers{totalrealtime} seconds playing NetHack on NAO";
 167
 168   $stats = naodash_user {include_versions => ['3.6.0']}, 'mgv';
 169   say 'mgv has ascended an orcish rogue in 3.6.0' if $checks{combo_rog_orc_cha};
 170   $stats = naodash_user {exclude_versions => ['3.6.0']}, 'mgv';
 171   say 'mgv has ascended an atheist character pre-3.6.0' if $checks{conduct_atheist};
 172
 173   use File::Slurp;
 174   $stats = naodash_xlog read_file 'path/to/my/xlogfile';
 175   %checks = map { $_ => 1 } @{$stats->{checks}};
 176   say 'I have ascended a survivor' if $checks{uconduct_survivor};
 177
 178 =head1 DESCRIPTION
 179
 180 NetHack::NAOdash analyzes a NetHack xlogfile and reports statistics.
 181 There are two types of statistics: B<checks>, which are flags
 182 (booleans) and B<numbers> which are integers.
 183
 184 The B<checks> are tracked across all games. That is, a B<check> will
 185 be true in the statistics if it is true in at least one game. Except
 186 for B<checks> in the I<Achievements> category, only games that end in
 187 an ascension are considered for awarding a B<check>.
 188
 189 The B<checks>, sorted by category, are:
 190
 191 =over
 192
 193 =item B<Achievements>
 194
 195 These start with C<achieve_> and represent significant milestones in a
 196 game. They are usually relevant only for users who never ascended, as
 197 a game that ends in an ascension generally meets all of them.
 198
 199   achieve_sokoban  achieve_luckstone   achieve_medusa achieve_bell
 200   achieve_gehennom achieve_candelabrum achieve_book   achieve_invocation
 201   achieve_amulet   achieve_endgame     achieve_astral achieve_ascended
 202
 203 =item B<Starting Combos>
 204
 205 These look like C<combo_role_race_alignment> and represent
 206 role/race/alignment combinations in ascended games. The starting
 207 alignment, not the alignment at the end of the game is considered. For
 208 example, C<cav_gno_neu> is true if the user ascended at least one
 209 gnomish caveman.
 210
 211 =item B<Conducts>
 212
 213 These start with C<conduct_> and represent the 12 officially tracked
 214 conducts.
 215
 216   conduct_foodless     conduct_vegan        conduct_vegetarian
 217   conduct_atheist      conduct_weaponless   conduct_pacifist
 218   conduct_illiterate   conduct_genocideless conduct_polypileless
 219   conduct_polyselfless conduct_wishless     conduct_artiwishless
 220
 221 =item B<Unofficial Conducts>
 222
 223 These start with C<uconduct_> and represent conducts that are not
 224 officially tracked by the game.
 225
 226   uconduct_survivor uconduct_bones uconduct_minscore
 227
 228 =back
 229
 230 The numbers are:
 231
 232 =over
 233
 234 =item B<totalrealtime>
 235
 236 The total time spent playing NetHack on NAO, in seconds.
 237
 238 =item B<games>
 239
 240 The number of games played.
 241
 242 =item B<ascensions>
 243
 244 The number of games played that ended in an ascension.
 245
 246 =item B<maxhp>
 247
 248 The highest maxHP at the end of an ascension.
 249
 250 =item B<maxpoints>
 251
 252 The highest score obtained at the end of an ascension.
 253
 254 =item B<maxconducts>
 255
 256 The maximum number of conducts at the end of an ascension.
 257
 258 =item B<minturns>
 259
 260 The minimum turns across ascended games.
 261
 262 =item B<minrealtime>
 263
 264 The minimum realtime across ascended games, in seconds.
 265
 266 =back
 267
 268 This module exports two functions:
 269
 270 =over
 271
 272 =item B<naodash_xlog>([\%args], I<@lines>)
 273
 274 =item B<naodash_xlog>([\%args], I<$xlog>)
 275
 276 Takes an optional hashref followed by the contents of an xlogfile and
 277 returns the results of the analysis. The contents are joined together
 278 then split by the newline character, so they can be specified as a
 279 single string, as a list of lines, or as a combination thereof.
 280
 281 The following keys are recognised in the optional hashref:
 282
 283 =over
 284
 285 =item include_versions
 286
 287 The associated value is an arrayref of NetHack versions that should be
 288 considered. Any game that was played on a version that is not in this
 289 arrayref will be ignored. If this key is not present or the value is
 290 an empty arrayref, all versions are considered.
 291
 292 =item exclude_versions
 293
 294 The associated value is an arrayref of NetHack versions that should
 295 not be considered. Any game that was played on a version that is in
 296 this arrayref will be ignored. If a version is both included and
 297 excluded at the same time, it will not be considered (in other words,
 298 exclude_versions overrides include_versions).
 299
 300 =back
 301
 302 The return value is of the following form:
 303
 304   { checks => ['achieve_sokoban', 'achieve_luckstone', ...],
 305     numbers => {totalrealtime => 12345, games => 2, ...} }
 306
 307 In other words, C<< @{$result->{checks}} >> is an array of B<checks>
 308 that are true and C<< %{$result->{numbers}} >> is a hash of
 309 B<numbers>.
 310
 311 =item B<naodash_user>([I<\%args>], I<$nao_username>)
 312
 313 Retrieves the xlogfile of a user from NAO and gives it to
 314 B<naodash_xlog>. Dies if no xlogfile is found or if the server cannot
 315 be contacted.
 316
 317 An optional hashref can be passed as a first argument. In this case it
 318 will be supplied as a first argument to B<naodash_xlog>, see that
 319 function's documentation for an explanation of useful keys.
 320
 321 This method caches the downloaded xlogfiles for one day in the
 322 directory named by the NAODASH_CACHE environment variable.
 323
 324 =back
 325
 326 =head1 ENVIRONMENT
 327
 328 =over
 329
 330 =item NAODASH_CACHE
 331
 332 Path to a directory that should be used to cache xlogfiles downloaded
 333 from NAO, or the special value 'none' (case-insensitive) to disable
 334 caching.
 335
 336 By default a directory named 'naodash' in the default temporary
 337 directory (C<< File::Spec->tmpdir >>) is used.
 338
 339 =back
 340
 341 =head1 SEE ALSO
 342
 343 L<App::NAOdash>, L<App::Web::NAOdash>, L<http://alt.org/nethack/>
 344
 345 =head1 AUTHOR
 346
 347 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 348
 349 =head1 COPYRIGHT AND LICENSE
 350
 351 Copyright (C) 2015 by Marius Gavrilescu
 352
 353 This library is free software; you can redistribute it and/or modify
 354 it under the same terms as Perl itself, either Perl version 5.20.2 or,
 355 at your option, any later version of Perl 5 you may have available.
 356
 357
 358 =cut