File Coverage

blib/lib/NetHack/PriceID.pm

Criterion	Covered	Total	%
statement	75	79	94.9
branch	46	54	85.1
condition	2	3	66.6
subroutine	12	12	100.0
pod	4	4	100.0
total	139	152	91.4

package NetHack::PriceID;
BEGIN {
  $NetHack::PriceID::AUTHORITY = 'cpan:SARTAK';
}
{
  $NetHack::PriceID::VERSION = '0.05';
}
use strict;
use warnings;
use integer;
# ABSTRACT: identify NetHack items using shopkeepers

use base 'Exporter';
our @EXPORT_OK = qw(priceid priceid_buy priceid_sell priceid_base);
our %EXPORT_TAGS = ('all' => \@EXPORT_OK);

our %glyph2type = (
    '"' => 'amulet',
    '?' => 'scroll',
    '+' => 'spellbook',
    '=' => 'ring',
    '!' => 'potion',
    '/' => 'wand',
    '(' => 'tool',
    '[' => 'armor',
);

our %item_table = (
    amulet => {
        0     => ['cheap plastic imitation of the Amulet of Yendor'],
        150   => ['change', 'ESP', 'life saving', 'magical breathing',
                  'reflection', 'restful sleep', 'strangulation',
                  'unchanging', 'versus poison'],
        30000 => ['Amulet of Yendor'],
    },

    scroll => {
        20  => ['identify'],
        50  => ['light'],
        60  => ['blank paper', 'enchant weapon'],
        80  => ['enchant armor', 'remove curse'],
        100 => ['confuse monster', 'destroy armor', 'fire',
                'food detection', 'gold detection', 'magic mapping',
                'scare monster', 'teleportation'],
        200 => ['amnesia', 'create monster', 'earth', 'taming'],
        300 => ['charging', 'genocide', 'punishment', 'stinking cloud'],
    },

    spellbook => {
        100 => ['detect monsters', 'force bolt', 'healing', 'jumping',
                'knock', 'light', 'protection', 'sleep'],
        200 => ['confuse monster', 'create monster', 'cure blindness',
                'detect food', 'drain life', 'magic missile',
                'slow monster', 'wizard lock'],
        300 => ['cause fear', 'charm monster', 'clairvoyance',
                'cure sickness', 'detect unseen', 'extra healing',
                'haste self', 'identify', 'remove curse',
                'stone to flesh'],
        400 => ['cone of cold', 'detect treasure', 'fireball',
                'invisibility', 'levitation', 'restore ability'],
        500 => ['dig', 'magic mapping'],
        600 => ['create familiar', 'polymorph', 'teleport away',
                'turn undead'],
        700 => ['cancellation', 'finger of death'],
    },

    potion => {
        0   => ['uncursed water'],
        50  => ['booze', 'fruit juice', 'see invisible', 'sickness'],
        100 => ['confusion', 'extra healing', 'hallucination', 'healing',
                'restore ability', 'sleeping', '(un)holy water'],
        150 => ['blindness', 'gain energy', 'invisibility',
                'monster detection', 'object detection'],
        200 => ['enlightenment', 'full healing', 'levitation', 'polymorph',
                'speed'],
        250 => ['acid', 'oil'],
        300 => ['gain ability', 'gain level', 'paralysis'],
    },

    ring => {
        100 => ['adornment', 'hunger', 'protection',
                'protection from shape changers', 'stealth',
                'sustain ability', 'warning'],
        150 => ['aggravate monster', 'cold resistance',
                'gain constitution', 'gain strength', 'increase accuracy',
                'increase damage', 'invisibility', 'poison resistance',
                'see invisible', 'shock resistance'],
        200 => ['fire resistance', 'free action', 'levitation',
                'regeneration', 'searching', 'slow digestion',
                'teleportation'],
        300 => ['conflict', 'polymorph', 'polymorph control',
                'teleport control'],
    },

    wand => {
        0   => ['uncharged'],
        100 => ['light', 'nothing'],
        150 => ['digging', 'enlightenment', 'locking', 'magic missile',
                'make invisible', 'opening', 'probing',
                'secret door detection', 'slow monster', 'speed monster',
                'striking', 'undead turning'],
        175 => ['cold', 'fire', 'lightning', 'sleep'],
        200 => ['cancellation', 'create monster', 'polymorph',
                'teleportation'],
        500 => ['death', 'wishing'],
    },

    bag => {
        2   => ['sack'],
        100 => ['bag of holding', 'oilskin sack', 'bag of tricks'],
    },

    lamp => {
        10 => ['oil lamp'],
        50 => ['magic lamp'],
    },

    flute => {
        12 => ['wooden flute'],
        36 => ['magic flute'],
    },

    horn => {
        15 => ['tooled horn'],
        50 => ['fire horn', 'frost horn', 'horn of plenty'],
    },

#    shirt => {
#        2 => ['T-shirt'],
#        3 => ['Hawaiian shirt'],
#    },

#    suit => {
#    },

    cloak => {
        50 => ['cloak of displacement', 'cloak of protection', 'oilskin cloak'],
        60 => ['cloak of invisibility', 'cloak of magic resistance',
               'elven cloak'],
    },

    helmet => {
         1 => ['dunce cap'],
        10 => ['helmet'],
        50 => ['helm of brilliance', 'helm of opposite alignment',
               'helm of telepathy'],
        80 => ['cornuthaum'],
    },

    gloves => {
         8 => ['leather gloves'],
        50 => ['gauntlets of dexterity', 'gauntlets of fumbling',
               'gauntlets of power'],
    },

#    shield => {
#        1 => [],
#    },

    boots => {
         8 => ['elven boots', 'kicking boots'],
        30 => ['fumble boots', 'levitation boots'],
        50 => ['jumping boots', 'speed boots', 'water walking boots'],
    },
);

# dynamically construct a list of all tools from each tool subtype
for my $in (qw/bag lamp flute horn/) {
    while (my ($price, $items) = each %{ $item_table{$in} }) {
        @{$item_table{tool}{$price}} = sort @{$item_table{tool}{$price} || []},
                                            @$items;
    }
}

# dynamically construct a list of all armor from each armor subtype
for my $in (qw/shirt suit cloak helmet gloves shield boots/) {
    # automatically calculate +1 .. +6
    my @prices = reverse sort keys %{ $item_table{$in} };
    for my $price (@prices) {
        for my $enchantment (1 .. 6) {
            my $newprice = $price + 10 * $enchantment;

            for my $item (@{ $item_table{$in}{$price} }) {
                push @{ $item_table{$in}{$newprice} }, "+$enchantment $item";
            }
        }
    }

    while (my ($price, $items) = each %{ $item_table{$in} }) {
        @{$item_table{armor}{$price}} = sort @{$item_table{armor}{$price}||[]},
                                             @$items;
    }
}

sub _croak {
    require Carp;
    Carp::croak(@_);
}

sub priceid {
    my %args = _canonicalize_args(@_);
    my @base;

    if ($args{in} eq 'sell') {
        @base = priceid_sell(%args, out => 'base');
    }
    elsif ($args{in} eq 'buy') {
        @base = priceid_buy(%args, out => 'base');
    }
    elsif ($args{in} eq 'base') {
        @base = priceid_base(%args, out => 'base');
    }

    return _canonicalize_output(\%args, @base);
}

sub priceid_buy {
    my %args = _canonicalize_args(@_);
    my @base;

    _croak "Calculating 'buy' prices requires that you set 'charisma'."
        if !defined $args{charisma};

    for my $base (keys %{ $item_table{ $args{type} } }) {
        my $tmp = $base;

        $tmp = 5 if !$tmp;

        my $surcharge = $tmp + $tmp / 3;

        for ($tmp, $surcharge) {
            $_ += $_ / 3 if $args{tourist};
            $_ += $_ / 3 if $args{dunce};

               if ($args{charisma} > 18) { $_ /= 2      }
            elsif ($args{charisma} > 17) { $_ -= $_ / 3 }
            elsif ($args{charisma} > 15) { $_ -= $_ / 4 }
            elsif ($args{charisma} < 6)  { $_ *= 2      }
            elsif ($args{charisma} < 8)  { $_ += $_ / 2 }
            elsif ($args{charisma} < 11) { $_ += $_ / 3 }

            $_ = 1 if $_ <= 0;

            if ($args{angry}) { $_ += ($_ + 2) / 3 }

            if (($_ * $args{quan}) == $args{amount}) {
                push @base, $base;
                last;
            }
        }
    }

    return _canonicalize_output(\%args, @base);
}

sub priceid_sell {
    my %args = _canonicalize_args(@_);
    my @base;

    for my $base (keys %{ $item_table{ $args{type} } }) {
        my $tmp = $base * $args{quan};

        if ($args{tourist})  { $tmp /= 3 }
        elsif ($args{dunce}) { $tmp /= 3 }
        else                 { $tmp /= 2 }

        my $surcharge = $tmp - $tmp / 4;
        $surcharge = $tmp unless $tmp > 1;

        for ($tmp, $surcharge) {
            if ($_ == $args{amount}) {
                push @base, $base;
                last;
            }
        }
    }

    return _canonicalize_output(\%args, @base);
}

sub priceid_base {
    my %args = _canonicalize_args(@_);
    return _canonicalize_output(\%args, $args{amount});
}

sub _canonicalize_args {
    my %args = (
        in   => 'base',
        out  => 'names',
        quan => 1,
        @_,
    );

    _croak "Price IDing requires that you set 'amount'"
        if !defined $args{amount};

    _croak "Price IDing requires that you set 'type'"
        if !defined $args{type};

    $args{type} = $glyph2type{ $args{type} } || $args{type};

    _croak "Unknown item type: $args{type}"
        if !exists $item_table{ $args{type} };

    return %args;
}

sub _canonicalize_output {
    my $args = shift;

    return map { [$_, @{ $item_table{ $args->{type} }{ $_ } || [] }] } sort @_
        if $args->{out} eq 'both';

    return sort @_ if $args->{out} eq 'base';
    return sort map {@{ $item_table{ $args->{type} }{ $_ } || [] }} @_;
}

1;

__END__