PERL Beginners - quantity discount calculation lookup tables

Author

quantity discount calculation lookup tables

Scott R. Godin

2005-08-15, 4:59 pm

I'd like to create a quantity discount table based on the following criterion

quantity 1 - 9 0%
quantity 10 - 19 25%
quantity 20 - 199 40%
quantity 200 - 499 50%
quantity 500+ 55%

I'd like to read it in via a __DATA__ handle, and perform the discount
calculation based on the total # of items (out of 6 individual items, each
priced differently but contributing to the total quantity towards the discount
percentage).

what are some perlish ways one would go about performing this calculation
efficiently ?

Jeff 'japhy' Pinyan

2005-08-15, 4:59 pm

On Aug 15, Scott R. Godin said:

> quantity 1 - 9 0%
> quantity 10 - 19 25%
> quantity 20 - 199 40%
> quantity 200 - 499 50%
> quantity 500+ 55%
>
> I'd like to read it in via a __DATA__ handle, and perform the discount
> calculation based on the total # of items (out of 6 individual items,
> each priced differently but contributing to the total quantity towards
> the discount percentage).
>
> what are some perlish ways one would go about performing this calculation
> efficiently ?

Well, if the quantities are going to be relatively small numbers, you
could use an array:

my @discount;

while (<DATA> ) {
if (my ($lower, $upper, $disc) = / (\d+) - (\d+) +(\d+)%/) {
@discount[$lower..$upper] = ($disc) x ($upper - $lower + 1);
}
elsif (my ($lower, $disc) = / (\d+)\+ +(\d+)%/) {
$discount[$lower] = $disc;
}
else {
warn "unsupported discount line (#$.): $_";
}
}

Then you would simply poll @discount to find out the rate; this is
assuming $quantity is some positive number:

my $rate = ($discount[$quantity] || $discount[-1]) / 100;

If there is no entry for $discount[$quantity], that means it's greater
than 500 (in your sample case), thus it gets the same discount as 500
items. Since $discount[500] is the last element in @discount, it's the
same as $discount[-1].

--
Jeff "japhy" Pinyan % How can we ever be the sold short or
RPI Acacia Brother #734 % the cheated, we who for every service
http://japhy.perlmonk.org/ % have long ago been overpaid?
http://www.perlmonks.org/ % -- Meister Eckhart

Wiggins d'Anconia

2005-08-15, 4:59 pm

Scott R. Godin wrote:
> I'd like to create a quantity discount table based on the following
> criterion
>
> quantity 1 - 9 0%
> quantity 10 - 19 25%
> quantity 20 - 199 40%
> quantity 200 - 499 50%
> quantity 500+ 55%
>
>
> I'd like to read it in via a __DATA__ handle, and perform the discount
> calculation based on the total # of items (out of 6 individual items,
> each priced differently but contributing to the total quantity towards
> the discount percentage).
>
> what are some perlish ways one would go about performing this
> calculation efficiently ?
>

See Jeff's answer as to how to code it up. But I would suggest
separating the min/max quantity fields, assuming there is no backwards
compatibility reason to keep them together, to me it is a better design
not to have to use a regex just to separate what should likely be two
fields. They can always be put back together easily but you are less
likely to do this frequently, if ever, and you are likely to do the
separation *a lot*.

Another suggestion would be to store your percentages as a number
between 0-1 rather than as an "actual percentage", then you can just
multiply by the number directly rather than having to divide by 100 each
time. Same efficiency assumption, you will show the percentage as a
human readable percentage less frequently then you will do the actual
calculations.

HTH,

http://danconia.org

Scott R. Godin

2005-08-15, 4:59 pm

Jeff 'japhy' Pinyan wrote:
> On Aug 15, Scott R. Godin said:
>
>
>
> Well, if the quantities are going to be relatively small numbers, you
> could use an array:
>
> my @discount;
>
> while (<DATA> ) {
> if (my ($lower, $upper, $disc) = / (\d+) - (\d+) +(\d+)%/) {
> @discount[$lower..$upper] = ($disc) x ($upper - $lower + 1);
> }
> elsif (my ($lower, $disc) = / (\d+)\+ +(\d+)%/) {
> $discount[$lower] = $disc;
> }
> else {
> warn "unsupported discount line (#$.): $_";
> }
> }

Oh, Jolly Good! though I'm somewhat concerned with how much memory that would
take up. Ultimately this would be running as a cgi processing a web-form
submission.

> Then you would simply poll @discount to find out the rate; this is
> assuming $quantity is some positive number:
>
> my $rate = ($discount[$quantity] || $discount[-1]) / 100;

almost. when $discount[1] = 0 that makes it assume the 55% discount instead. see
below.

> If there is no entry for $discount[$quantity], that means it's greater
> than 500 (in your sample case), thus it gets the same discount as 500
> items. Since $discount[500] is the last element in @discount, it's the
> same as $discount[-1].
>

I've modified it slightly, to add strictness and also my pricing/products table.

#!/usr/bin/perl
use warnings;
use strict;

my (@discount, %price);
while ( <DATA> )
{
chomp;
if ( /^quantity/)
{
my($lower, $upper, $disc);
if ( ($lower, $upper, $disc) = /(\d+)\s+-\s+(\d+)\s+(\d+)%$/ )
{
@discount[$lower..$upper] = ($disc) x ($upper - $lower + 1);
}
elsif ( ($lower, $disc) = /(\d+)\+\s+(\d+)%$/ )
{
$discount[$lower] = $disc;
}
else
{
warn "unsupported discount line (#$.): $_";
}
next;
}
if ( /^price/ )
{
if (my($book, $retail) = /(\w+)\s+\$([\d.]+)$/)
{
$price{$book} = $retail;
}
else
{
warn "unsupported price line (#$.): $_";
}
next;
}
warn "nonmatching line in DATA table: '$_'";# fallthrough
}

for (1 .. 20 )
{
my $rate = (defined($discount[$_]) ? $discount[$_] : $discount[-1]) / 100;
print "$_, $rate\n";
}

__DATA__
quantity 1 - 9 0%
quantity 10 - 19 25%
quantity 20 - 199 40%
quantity 200 - 499 50%
quantity 500+ 55%
price rkh $15.95
price rkp $6.95
price rmh $15.95
price rmp $6.95
price rbh $15.95
price rbp $6.95

Jeff 'japhy' Pinyan

2005-08-15, 4:59 pm

On Aug 15, Scott R. Godin said:

> Jeff 'japhy' Pinyan wrote:
>
> Oh, Jolly Good! though I'm somewhat concerned with how much memory that would
> take up. Ultimately this would be running as a cgi processing a web-form
> submission.

Unless you're dealing with thousands of elements in your array, I wouldn't
expect a noticeable effect.

>
> almost. when $discount[1] = 0 that makes it assume the 55% discount instead.
> see below.

Oh, right, my bad.

--
Jeff "japhy" Pinyan % How can we ever be the sold short or
RPI Acacia Brother #734 % the cheated, we who for every service
http://japhy.perlmonk.org/ % have long ago been overpaid?
http://www.perlmonks.org/ % -- Meister Eckhart

Scott R. Godin

2005-08-25, 9:55 pm

Jeff 'japhy' Pinyan wrote:
> On Aug 15, Scott R. Godin said:
>
>
>
> Unless you're dealing with thousands of elements in your array, I
> wouldn't expect a noticeable effect.
>
>
>
> Oh, right, my bad.
>

Ultimately it worked out to the below. I'd be interested in seeing any further
suggestions you all may have.

use Carp qw{carp croak};

{# closure to retain value tables for subs in this section
my (@discount, %price, @shiprate);
while ( <DATA> )
{
chomp;
if ( /^quantity/)
{
my($lower, $upper, $disc);
if ( ($lower, $upper, $disc) = /(\d+)\s+-\s+(\d+)\s+(\d+)%\s*$/ )
{
@discount[$lower..$upper] = ($disc) x ($upper - $lower + 1);
}
elsif ( ($lower, $disc) = /(\d+)\+\s+(\d+)%\s*$/ )
{
$discount[$lower] = $disc;
}
else
{
die "unsupported discount line (#$.): '$_'";
}
next;
}
if ( /^price/ )
{
if (my($book, $retail) = /(\w+)\s+\$([\d.]+)\s*$/)
{
$price{$book} = $retail;
}
else
{
die "unsupported price line (#$.): '$_'";
}
next;
}
if ( /^shipping/ )
{
if ( my($lower, $upper, $rate) = /(\d+)\s+-\s+(\d+)\s+\$(\d+)\s*$/ )
{
@shiprate[$lower .. $upper] = ($rate) x ($upper - $lower + 1);
}
else
{
die "unsupported shipping line (#$.): '$_'";
}
next;
}
warn "nonmatching line in DATA table (#$.): '$_'";
}

sub _discount (@)
{
my(@quantities, $qty) = @_;
$qty += $fields{$_}[0] for @quantities;
return 0 unless defined($qty) and $qty =~ /^\d+$/ and $qty > 0;
return ((defined($discount[$qty]) ? $discount[$qty] : $discount[-1]) / 100);
}

sub _price ($)
{
my $book = shift;
croak "Unknown book $book" unless exists $price{$book};
return $price{$book};
}

sub _shipping
{
my( @books ) = keys %price;
my $total_quantity = 0;
foreach my $book ( @books )
{
croak "Unknown Book $book " unless exists $price{$book};

if ( $fields{"${book}_quantity"}[0] =~ /^\d+$/)
{
$total_quantity += $fields{"${book}_quantity"}[0];
}
else
{
croak("Invalid Quantity for '$book' : '",
$fields{"${book}_quantity"}[0]. "'" );
}
}
#quantity less than or equal to highest quantity we ship in one box
if ($total_quantity <= $#shiprate )
{
return ( $shiprate[$total_quantity] );
}
my $total_shipping =
($shiprate[-1] * int($total_quantity / $#shiprate))
+ $shiprate[ $total_quantity % $#shiprate ];
return $total_shipping;
}

my %unit;
sub _unit ($)
{
my $book = shift;
croak "Unknown book $book" unless exists $price{$book};
return $unit{$book} if $unit{$book};
my $price = _price($book)
or croak "Warning: DATA contains No Price for $book";
my $rate = _discount( grep{ /_quantity$/ } keys %fields );
$unit{$book} = sprintf( "%.2f", $price - sprintf( "%.2f", $price * $rate ));
$unit{"$book total"} =
sprintf( "%.2f", $fields{"${book}_quantity"}[0] * $unit{$book});
$unit{subtotal} += $unit{"$book total"};
return $unit{$book};
}

sub _unit_total ($)
{
my $book = shift;
croak "Unknown book $book" unless exists $price{$book};
return $unit{"$book total"} if $unit{"$book total"};
_unit($book) && return $unit{"$book total"};
}

sub _subtotal
{
croak "Subtotal called too early" unless defined $unit{subtotal};
return ( sprintf("%.2f", $unit{subtotal}) );
}

}

__DATA__
quantity 0 - 9 0%
quantity 10 - 19 25%
quantity 20 - 199 40%
quantity 200 - 499 50%
quantity 500+ 55%
price rkh $15.95
price rkp $6.95
price rmh $15.95
price rmp $6.95
price rbh $15.95
price rbp $6.95
shipping 0 - 0 $0
shipping 1 - 2 $4
shipping 3 - 6 $6
shipping 7 - 10 $8
shipping 11 - 20 $10
shipping 21 - 30 $12
shipping 31 - 40 $16

Sponsored Links