Perl Simple FIFO calculation

user_16110700 0
Viewed 163

I can not seem to get this FIFO calculation to work:

@base = (10,15,6,2);
@subtr = (2,4,6,2,2,5,7,2);

my $count = 0;
my $result;
my $prev;
foreach my $base1 (@base) {
    foreach my $subt (@subtr) {
        if ($count == 0) {
            $result = $base1 - $subt;
            print "$base1 - $subt = $result \n";
            if ($result > 0) {
                print "Still1 POS $result\n";
                $count = 1;
            } else {
                print "NEG1 now $result\n";
                $count = 1;
                next;
            }
        } else {
            $prev = $result;
            $result = $result - $subt;
            print "$prev - $subt = $result \n";
            if ($result > 0) {
                print "Still2 POS $result\n";
                next;
            } else {
                print "NEG2 now $result\n";
                $count = 1;
                next;
            }
        }
    }
    $count = 0;
}

I need it to subtract the numbers in @subtr from the 1st array @base, once the sum of the subt elements exceeds the 1st element of the @base array, for it to use the amount exceeded and subtract from second element of @base, etc until it is done. Once done, I need it to tell me which array from @base it finished on and how much is left from that array element( should be 1) and then how much is left total (should be 3). Thank you in advance! Paul

fifo perl arrays
2 Answers
use warnings;
use strict;
use feature 'say';
use List::Util 1.33 qw(sum any);  # 'any' was in List::MoreUtils pre-1.33

my @base = (10,15,6,2);
my @subt = (2,4,6,2,2,5,7,2);  # SUBTract from @base in a particular way ("FIFO")

# For testing other cases:
#my @subt = (2,4,6,2,2,5,7,2,5,5);  # @base runs out
#my @subt = (2,4,36,20);            # large @subt values, @base runs out
#my @subt = (2,4,21,2);             # large @subt values, @base remains
#my @subt = (2,4,6,2,2,5,7,2,3);    # @base runs out, @subt runs out

say "base: @base (total: ", sum(@base), ")";
say "sub:  @subt (total: ", sum (@subt), ")\n" if @subt;

my ($base_idx, $carryover) = (0, 0);

BASE_ELEM:
for my $bi (0..$#base) {
    $base[$bi] -= $carryover;

    # If still negative move to next @base element, to use carry-over on it
    if ($base[$bi] <= 0) {
        $carryover = abs($base[$bi]);
        say "\t\@base element #", $bi+1, " value $base[$bi] (-> 0); ",
            "carry over $carryover.";
        $base[$bi] = 0;
        next BASE_ELEM;
    }

    # Subtract @subt elements until they're all gone or $base[$bi] < 0
    1 while @subt and ($base[$bi] -= shift @subt) > 0;

    # Either @base element got negative, or we ran out of @subt elements
    if ($base[$bi] <= 0) {
        $carryover = abs($base[$bi]);
        say "\@base element #", $bi+1, " emptied. carry-over: $carryover. ",
            "Stayed with \@sub: @subt";
        $base[$bi] = 0;
    }
    elsif (not @subt) {  # we're done
        $base_idx = $bi;
        say "\@base element #", $bi+1, " emptied. carry-over: $carryover. ",
            "Stayed with ", scalar @subt, " \@subt elements";
        last BASE_ELEM;
    }
}
my $total_base_value = sum @base;

say "\nStayed with base: @base";

if (any { $_ > 0 } @base) {  # some base elements remained
    say "Stopped at \@base element index $base_idx (element number ",
        $base_idx+1, "), with value $base[$base_idx]";
}
else {
    if ($carryover) {
        say "Last carry-over: $carryover. Put it back at front of \@subt";
        unshift @subt, $carryover;
    }
    if (@subt) { say "Remained with \@subt elements: @subt" }
    else       { say "Used all \@subt to deplete all \@base" }
}

say "Total remaining: $total_base_value";

Prints

base: 10 15 6 2 (total: 33)
sub:  2 4 6 2 2 5 7 2 (total: 30)

@base element #1 emptied. carry-over: 2. Stayed with @sub: 2 2 5 7 2
@base element #2 emptied. carry-over: 3. Stayed with @sub: 2
@base element #3 emptied. carry-over: 3. Stayed with 0 @subt elements

Stayed with base: 0 0 1 2
Stopped at @base element index 2 (element number 3), with value 1
Total remaining: 3

(See end for version without diagnostic prints)

There are other possible cases, indicated by commented-out different @subt inputs

  • that @base runs out while there are still non-zero @subt elements. The simplest such case can be tested by using the next (commented-out) @subt input line; its additional elements keep nibbling away at @base values and deplete it altogether, with some @subt remaining

  • that all @base is driven to zero and @subt exactly runs out! This conspiracy can be effected with input such that @base and @subt add up to same (last commented-out @subt input)

  • that some @subt elements are large enough to make a @base element so negative that there is enough of carry-over to deplete the next one, etc. This is handled in the first if test, where we skip directly to the next @base element if there is still extra negative (to be carry-over), so that it can get used on it, etc

A note. A @subt element is always first removed from its front (by shift) and then subtracted from a @base element. If that made that @base element negative, the negative value is used for carry-over and applied to the next @base element.

But, if that finally drove the last @base element into negative, the extra (negative) amount is considered to have stayed in that @subt's element; it is put back at @subt's front (unshift-ed).

Example: we had 5 (of some moneys, let's imagine) left in @base's last element, and @subt's element subtracted from it was 7. Then that @base's element is made into zero and that @subt's element stays at 2.

The code works with empty @subt as well.

Without extra prints in the loop, for easier reviewing

use warnings;
use strict;
use feature 'say';
use List::Util 1.33 qw(sum any);  # 'any' was in List::MoreUtils pre-1.33

my @base = (10,15,6,2);
my @subt = (2,4,6,2,2,5,7,2);
# For testing other cases:
#my @subt = (2,4,6,2,2,5,7,2,5,5);  # @base runs out
#my @subt = (2,4,36,20);            # large @subt values, @base runs out
#my @subt = (2,4,21,2);             # large @subt values, @base remains
#my @subt = (2,4,6,2,2,5,7,2,3);    # @base runs out, @subt runs out
say "base: @base (total: ", sum(@base), ")";
say "sub:  @subt (total: ", sum (@subt), ")\n" if @subt;

my ($base_idx, $carryover) = (0, 0);

for my $bi (0..$#base) {
    $base[$bi] -= $carryover;

    # If still negative move to next @base element, to use carry-over on it
    if ($base[$bi] <= 0) {
        $carryover = abs($base[$bi]);
        $base[$bi] = 0;
        next;
    }

    # Subtract @subt elements until they're all gone or $base[$bi] < 0
    1 while @subt and ($base[$bi] -= shift @subt) > 0;

    # Either @base element got negative, or we ran out of @subt elements
    if ($base[$bi] <= 0) {
        $carryover = abs($base[$bi]);
        $base[$bi] = 0;
    }
    elsif (not @subt) {  # we're done
        $base_idx = $bi;
        last;
    }
}
my $total_base_value = sum @base;

say "Stayed with base: @base";

if (any { $_ > 0 } @base) {  # some base elements remained
    say "Stopped at \@base element index $base_idx (element number ",
        $base_idx+1, "), with value $base[$base_idx]";
}
else {
    unshift @subt, $carryover  if $carryover;

    if (@subt) { say "Remained with \@subt elements: @subt" }
    else      { say "Used all \@subt to deplete all \@base" }
}

say "Total remaining: $total_base_value";
user_46533790

I'm not sure what the expected values should be when you exhaust @base before exhausting @subtr. For the input you gave, it seems to work, though:

#!/usr/bin/perl
use strict;
use warnings;
use feature qw{ say };

my @base = (10, 15, 6, 2);
my @subtr = (2, 4, 6, 2, 2, 5, 7, 2);

my ($base_index, $subtr_index) = (0, 0);
my $subtracted = 0;

while ($base_index <= $#base) {
    while ($base[$base_index] - $subtracted > 0 && $subtr_index <= $#subtr) {
        say "Subtract at $subtr_index: $subtr[$subtr_index]";
        $subtracted += $subtr[$subtr_index++];
        say "Remains: ", $base[$base_index] - $subtracted;
    }
    last if $subtr_index > $#subtr;

    say "$base[$base_index] <= $subtracted";
    $subtracted -= $base[$base_index++];
    if ($base_index > $#base) {
        --$base_index;
        last
    }
    say "Carrying $subtracted to index $base_index ($base[$base_index])";
}
say "Finished at base index $base_index ($base[$base_index])";
say "Remaining value: ", $base[$base_index] - $subtracted;
my $remaining = $base[$base_index] - $subtracted;
$remaining += $_ for @base[$base_index + 1 .. $#base];
say "Remaining total: $remaining";

But I find working with copies of the arrays and removing their elements easier to understand:

#!/usr/bin/perl
use strict;
use warnings;
use feature qw{ say };

my @base = (10, 15, 6, 2);
my @subtr = (2, 4, 6, 2, 2, 5, 7, 2);

my @copy_base = @base;
my @copy_subtr = @subtr;

while (@copy_base && @copy_subtr) {
    if ($copy_base[0] > $copy_subtr[0]) {
        $copy_base[0] -= shift @copy_subtr;
    } else {
        my $first = shift @copy_base;
        $copy_base[0] += $first;
        if (1 == @copy_base && $copy_base[0] <= $copy_subtr[0]) {
            $copy_subtr[0] -= $copy_base[0];
            @copy_base = ();
        }
    }
    # say "b:@copy_base";
    # say "s:@copy_subtr";
    # say "";
}

if (@copy_base) {
    say "Ended at base index ", @base - @copy_base;
    say "Value left: ", $copy_base[0];

    my $total = 0;
    $total += $_ for @copy_base;
    say "Total: ", $total;
} else {
    say "Base exhausted";
}
if (@copy_subtr) {
    say "Ended at subtr index ", @subtr - @copy_subtr;
    my $remain = 0;
    $remain += $_ for @copy_subtr;
    say "$remain wasn't subtracted" if $remain;
} else {
    say "Subtr exhausted";
}
user_10306750
Related