The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package NetHack::Inventory;
BEGIN {
  $NetHack::Inventory::VERSION = '0.13';
}
use Moose;
with 'NetHack::ItemPool::Role::HasPool';

use NetHack::Inventory::Equipment;

use constant equipment_class => 'NetHack::Inventory::Equipment';

has inventory => (
    traits    => ['Hash'],
    is        => 'ro',
    isa       => 'HashRef[NetHack::Item]',
    default   => sub { {} },
    handles   => {
        get       => 'get',
        set       => 'set',
        remove    => 'delete',
        items     => 'values',
        slots     => 'keys',
        has_items => 'count',
    },
);

has equipment => (
    is      => 'ro',
    isa     => 'NetHack::Inventory::Equipment',
    lazy    => 1,
    handles => qr/^(?!update|remove|(has_)?pool|slots)\w/,
    default => sub {
        my $self = shift;
        $self->equipment_class->new(
            pool => $self->pool,
        )
    },
);

has weight => (
    is      => 'ro',
    isa     => 'Int',
    lazy    => 1,
    builder => '_calculate_weight',
    clearer => 'invalidate_weight',
);

has '+pool' => (
    required => 1,
);

sub _extract_slot {
    my ($slot, $item);

    if (@_ == 2) {
        ($slot, $item) = @_;
        $item->slot($slot);
    }
    else {
        $item = shift;
        $slot = $item->slot;
        confess "No slot was passed to set, and the item ($item) didn't have a value for its slot attribute." if !defined($slot);
    }

    return $slot => $item;
}

around set => sub {
    my $orig = shift;
    my $self = shift;

    my ($slot, $item) = _extract_slot(@_);

    # gold pieces don't belong in inventory
    return if $item->has_identity
           && $item->identity eq 'gold piece';

    $self->$orig($slot => $item);
};

sub update {
    my $self = shift;
    my $args = ref($_[0]) eq 'HASH' ? shift : {};
    my ($slot, $item) = _extract_slot(@_);

    # gold pieces don't belong in inventory
    return if $item->has_identity
           && $item->identity eq 'gold piece';

    if (my $old = $self->get($slot)) {
        if ($item->is_evolution_of($old)) {
            my $old_quantity = $old->quantity;
            $old->incorporate_stats_from($item);
            $old->slot($slot);
            $old->quantity($old_quantity + $item->quantity)
                if $args->{add} && $old->stackable;

            $self->equipment->update($old);
            $self->invalidate_weight;
        }
        else {
            warn "Displacing [" . $old->raw . "] in slot $slot with "
               . "[" . $item->raw . "].";
            $self->set($slot => $item);
        }

        return $old;
    }

    $self->set($slot => $item);
    return $item;
}

sub add { shift->update({add => 1}, @_) }

after 'set' => sub {
    my $self = shift;
    my $args = ref($_[0]) eq 'HASH' ? shift : {};
    my (undef, $item) = _extract_slot(@_);

    $self->equipment->update($item);
    $self->invalidate_weight;
};

before remove => sub {
    my $self = shift;
    my $item = $self->get(shift);

    $self->equipment->remove($item);
};

sub exact_weight {
    my $self = shift;

    my $weight = 0;
    for my $item ($self->items) {
        return undef if !defined($item->weight);
        $weight += $item->weight;
    }

    return $weight;
}

sub _calculate_weight {
    my $self = shift;

    my ($total_min, $total_max) = (0, 0);
    for my $item ($self->items) {
        my ($min, $max) = (sort $item->spoiler_values('weight'))[0, -1];
        $total_min += $min * $item->quantity;
        $total_max += $max * $item->quantity;
    }

    return int(($total_max + $total_min) / 2);
}

sub decrease_quantity {
    my $self = shift;
    my $slot = shift;
    my $by   = shift || 1;

    my $item = $self->get($slot);
    if (!$item) {
        warn "Inventory->decrease_quantity called on an empty slot '$slot'";
        return 0;
    }

    my $orig_quantity = $item->quantity;

    if ($by >= $orig_quantity) {
        $self->remove($slot);
        return 0;
    }

    $item->quantity($orig_quantity - $by);
    return $item->quantity;
}

__PACKAGE__->meta->make_immutable;
no Moose;

1;

__END__

=head1 NAME

NetHack::Inventory - the player's inventory

=head1 VERSION

version 0.13

=head1 SYNOPSIS

    use NetHack::ItemPool;
    my $pool = NetHack::ItemPool->new;

    $pool->new_item("x - 3 food rations");
    $pool->inventory->get('x'); # NetHack::Item<3 food rations>

    $pool->new_item("M - a unicorn horn");

    # updates (not replaces!) the horn already in M
    $pool->new_item("M - a blessed unicorn horn");

    # replaces the horn in M because it's a different item
    $pool->new_item("M - a scroll of taming");

=head1 DESCRIPTION

=cut