File Coverage

blib/lib/NetHack/NAOdash.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	36	94.4

package NetHack::NAOdash;

use 5.014000;
use strict;
use warnings;
use re '/saa';
use parent qw/Exporter/;

our $VERSION = '0.001';
our @EXPORT_OK = qw/naodash_xlog naodash_user/;
our @EXPORT = @EXPORT_OK;

use HTTP::Tiny;
use List::Util qw/max min sum/;
use List::MoreUtils qw/uniq/;
use Text::XLogfile qw/parse_xlogline/;

sub won_game {
	my %game = @_;
	$game{death} eq 'ascended'
}

our @check_subs = (
	sub { # Combos
		my %game = @_;
		return unless won_game %game;
		$game{align0} //= $game{align};
		"combo_$game{role}_$game{race}_$game{align0}"
	},

	sub { # Achievements
		my %game = @_;
		my @achieves = qw/bell gehennom candelabrum book invocation amulet endgame astral ascended luckstone sokoban medusa/;
		map { $game{achieve} & (1 << $_) ? "achieve_$achieves[$_]" : () } 0 .. $#achieves
	},

	sub { # Conducts
		my %game = @_;
		return unless won_game %game;
		my @conducts = qw/foodless vegan vegetarian atheist weaponless pacifist illiterate polypileless polyselfless wishless artiwishless genocideless/;
		map { $game{conduct} & (1 << $_) ? "conduct_$conducts[$_]" : () } 0 .. $#conducts
	},

	sub { # Unofficial conducts
		my %game = @_;
		return unless won_game %game;
		my @uconducts;
		push @uconducts, 'survivor' if $game{deaths} == 0;
		push @uconducts, 'boneless' unless $game{flags} & 32;
		push @uconducts, 'minscore' if $game{points} - 100 * ($game{maxlvl} - 45) == 24_400;
		map { "uconduct_$_" } @uconducts
	},
);

our %sum_subs = (
	games => sub { 1 },
	ascensions => sub {
		my %game = @_;
		!!won_game %game
	},
	totalrealtime => sub {
		my %game = @_;
		$game{realtime} // 0
	},
);

sub make_attr_sub ($) { ## no critic (ProhibitSubroutinePrototypes)
	my ($attr) = @_;
	sub {
		my %game = @_;
		return unless won_game %game;
		$game{$attr} // ()
	},
}

our %max_subs = (
	maxhp => make_attr_sub 'maxhp',
	maxpoints => make_attr_sub 'points',
	maxconducts => make_attr_sub 'nconducts',
);

our %min_subs = (
	minturns => make_attr_sub 'turns',
	minrealtime => make_attr_sub 'realtime',
);

sub naodash_xlog { ## no critic (RequireArgUnpacking)
	my ($xlog) = join '', @_;
	my %number_subs = (%sum_subs, %max_subs, %min_subs);

	my @checks;
	my %numbers = map { $_ => [] } keys %number_subs;

	for my $logline (split /\n/, $xlog) {
		my %game = %{parse_xlogline $logline};
		for (keys %game) {
			delete $game{$_} if $game{$_} eq ''
		}
		next if $game{flags} & 3; # flag 0x01 is wizard mode, 0x02 is explore mode
		push @checks, $_->(%game) for @check_subs;
		push @{$numbers{$_}}, $number_subs{$_}->(%game) for keys %number_subs;
	}

	$numbers{$_} = sum @{$numbers{$_}} for keys %sum_subs;
	$numbers{$_} = max @{$numbers{$_}} for keys %max_subs;
	$numbers{$_} = min @{$numbers{$_}} for keys %min_subs;
	@checks = uniq map { lc } @checks;

	{checks => [sort @checks], numbers => \%numbers}
}

my $ht = HTTP::Tiny->new(agent => "NetHack-NAOdash/$VERSION ");

sub naodash_user {
	my ($name) = @_;
	my $ret = $ht->get("http://alt.org/nethack/player-all-xlog.php?player=$name");
	die 'Error while retrieving xlogfile from alt.org: ' . $ret->{status} . ' ' . $ret->{reason} . "\n" unless $ret->{success};
	my ($xlog) = $ret->{content} =~ m{(.*)}i;
	die "No xlogfile found for user $name\n" unless defined $xlog;
	naodash_xlog $xlog;
}

1;
__END__