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