Magical Auto-Decrement

[John M. Dlugosz]

A few minutes ago, a node was posted as to why auto-decrement (--) wasn't magical. Since auto-increment is, this seems natural. It inspired me to throw together just such a function.

This is brute force, but it works. It's surprisingly difficult for something that looks so simple! So I'd love to see how this can be improved on—what language features could be brought to bear?

Perhaps reverse the string, then do a s///ge with inline code for a done flag as a zero-width lookahead, and the predchar feature in the replacement? Yaphy?

—John

use strict;
use warnings;

sub predchar
# modify argument in place.
# return true if no carry (done).
 {
 my $ord= ord($_[0]);
 my $nocarry;
 # define the ranges available
 my @ranges= ( [ord('0'),ord('9')], [ord('a'),ord('z')], [ord('A'),ord
+('Z')] );
 foreach my $range (@ranges) {
    my ($first,$last)= @$range;
    next unless $ord >= $first && $ord <= $last;  # my range?
    if ($ord == $first) { $ord= $last }
    else {
       --$ord;
       $nocarry= 1;
       }
    }
 $_[0]= chr($ord);
 return $nocarry;
 }

sub magic_decrement($)
 {
 my @chars= split ('', shift);
 for (my $loop= $#chars;  $loop>=0;  --$loop) {
    last if predchar ($chars[$loop]);
    }
 return join ('',@chars);
 }

sub test
 {
 my $s= shift || $_;
 my $result= magic_decrement($s);
 print qq{--"$s" gives "$result"\n};
 }

while (<DATA>) { chomp; test; }

__DATA__
123
abc
testbaA
ignore punct.

[Brovnik]

Nice try, but of course, the issue re. the boundary cases still holds, so the following

--"a" gives "z"
--"a00" gives "z99"
--"0" gives "9"
--"aa00" gives "zz99"

give results which aren't reversible. Update: (following comment below)

Yes, you should eat the left-char on underflow, and --"a" => undef and --0 => undef.

I was going to make a point about keeping items in the right order for a sort, but of course zz++ == aaa which screws up that point. Hmmm...
--
Brovnik

[John M. Dlugosz]

Looks like increment will add another character upon overflow, presumably duplicating the kind of the previous leftmost. To undo ++, the -- could eat the leftmost upon underflow. But ++ can't always be the exact opposite since it doesn't know which kind of character to add.

I'm aware that I'm clamping on underflow. It's a snippet, not a polished module! It was done more for the challange, but if I really needed this (like the poster that inspired it), I'd have the function croak or something, if this was significant to the program.

—John

[Anonymous Monk]

I massaged the code a bit to work on the boundary cases, and added a reverse (autoincrement) output to test the input. Unfortunately it seems to crap out on punctuation now.

Here is the output:

--"120" gives "119" reverse "120"
--"abc" gives "abb" reverse "abc"
--"testbaA" gives "testazZ" reverse "testbaA"
--"a" gives "" reverse "1"
--"aaa" gives "zz" reverse "aaa"
--"a01" gives "a00" reverse "a01"
--"aa00" gives "z99" reverse "aa00"


Here is the code:



use strict;
use warnings;

sub predchar {
# modify argument in place.
# return true if no carry (done).
    my $ord= ord($_[0]);
    my $nocarry;
    # define the ranges available
    my @ranges= ([ord('a'),ord('z')], [ord('A'),ord('Z')] );
    foreach my $range (@ranges) {
        my ($first,$last)= @$range;
        next unless $ord >= $first && $ord <= $last;  # my range?
        if ($ord == $first) { $ord= $last; }
        else {
            $nocarry = 1;
            --$ord;
        }
    }
    $_[0]= chr($ord);
    return $nocarry;
}

sub magic_decrement($)
 {
     my $instr = $_;
     my $numpart = $instr;
     my $alphapart = $instr;
     $numpart =~ s/[A-Za-z]+//;
     $alphapart =~ s/[0-9]+//;
     my $numlen = length($numpart);
     $numpart--;
     if($numpart == -1) {
        $numpart = '9' x $numlen;
        my @chars= split ('', $alphapart);
        my @retarr = @chars[0 .. $#chars];
        for (my $loop= $#chars;  $loop>=0;  --$loop) {
            last if predchar ($retarr[$loop]);
        }
        $alphapart = join ('',@retarr);
        $alphapart =~ s/z$// if($alphapart =~ /^z+$/);
     } else {
        $numpart = '0' . $numpart if($numlen != length($numpart));
     }
     return $alphapart . $numpart;
 }

sub test
 {
 my $s= shift || $_;
 my $result= magic_decrement($s);
 my $reverse = $result;
 $reverse++;
 print qq{--"$s" gives "$result" reverse "$reverse"\n};
 }

while (<DATA>) { chomp; test; }

__DATA__
120
abc
testbaA
a
aaa
a01
aa00

[Anonymous Monk]

Oops, forgot uppercase and number only situations. Here is some output that shows the boundaries of the algorithm, and the updated code:

--"120" gives "119" reverse "120"
--"abc" gives "abb" reverse "abc"
--"testbaA" gives "testazZ" reverse "testbaA"
--"a" gives "" reverse "1"
--"aaa" gives "zz" reverse "aaa"
--"a01" gives "a00" reverse "a01"
--"aA00" gives "z99" reverse "aa00"
--"Aa00" gives "Z99" reverse "AA00"
--"a00" gives "99" reverse "100"
--"0" gives "-1" reverse "0"



use strict;
use warnings;

sub predchar {
# modify argument in place.
# return true if no carry (done).
    my $ord= ord($_[0]);
    my $nocarry;
    # define the ranges available
    my @ranges= ([ord('a'),ord('z')], [ord('A'),ord('Z')] );
    foreach my $range (@ranges) {
        my ($first,$last)= @$range;
        next unless $ord >= $first && $ord <= $last;  # my range?
        if ($ord == $first) { $ord= $last; }
        else {
            $nocarry = 1;
            --$ord;
        }
    }
    $_[0]= chr($ord);
    return $nocarry;
}

sub magic_decrement($)
 {
    my $instr = $_;
    my $numpart = $instr;
    my $alphapart = $instr;
    $numpart =~ s/[A-Za-z]+//;
    $alphapart =~ s/[0-9]+//;
    my $numlen = length($numpart);
    $numpart--;
    if($alphapart) {
         if($numpart == -1) {
            $numpart = '9' x $numlen;
            my @chars= split ('', $alphapart);
            my @retarr = @chars[0 .. $#chars];
            for (my $loop= $#chars;  $loop>=0;  --$loop) {
                last if predchar ($retarr[$loop]);
            }
            $alphapart = join ('',@retarr);
            $alphapart =~ s/[Zz]$// if($alphapart =~ /^[Zz]+$/);
         } else {
            $numpart = '0' . $numpart if($numlen != length($numpart));
         }
    }
    return $alphapart . $numpart;
 }

sub test
 {
 my $s= shift || $_;
 my $result= magic_decrement($s);
 my $reverse = $result;
 $reverse++;
 print qq{--"$s" gives "$result" reverse "$reverse"\n};
 }

while (<DATA>) { chomp; test; }

__DATA__
120
abc
testbaA
a
aaa
a01
aA00
Aa00
a00
0