comment on

Now you can write arbitrarilly-nested loops easily.

Today in the CB, artist proposed a "math"¹ puzzle (heavily paraphrased by me): Find a set of numbers where each is composed of the exact same set of digits just in different orders, such that the numbers sum to 2003. For example, if I had asked about 2070, you would tell me 2070 = 198+891+981.

I fairly quickly threw together some code to search for a solution. I decided that adding 1 together 2003 times was not interesting and neither was adding 2003 up once. I didn't want to allow leading zeros nor repeated digits and I wanted the digit orders to be different for each number so I knew I only had to worry about picking 3 digits:

my %h;
for my $x ( 1..9 ) {
   for my $y ( $x+1..9 ) {
      for my $z ( $y+1..9 ) {
         my @a= ( $x, $y, $z );
         my @p;
         do {
            push @p, join "", @a;
         } while(  nextPermute(@a)  );
         for my $i ( 0..$#p ) {
            for my $j ( $i+1..$#p ) {
               for my $k ( $j+1..$#p ) {
                  $h{$p[$i]+$p[$j]+$p[$k]}
                     .= "=$p[$i]+$p[$j]+$p[$k]";
               }
            }
         }
      }
   }
}
for my $k (  1990 .. 2010  ) {
    print "$k=$h{$k}\n"   if  exists $h{$k};
}
[download]

which I combined with Permuting with duplicates and no memory to produce:

1998=189+891+918=198+819+981=279+792+927=...
2004=149+914+941=617+671+716=527+725+752
2007=198+891+918=387+783+837=459+594+954=...
[download]

So, no "good" solution for 2003. So I started widening the search by allowing zeros, repeated digits, repeated orderings (by simply changing "0" to "1" and dropping a few "+1"s). Still no solution.

So, since I was allowing repeated orderings, maybe I should add up more than 3 numbers. So I changed the code to add up 4 numbers and found:

2003=089+098+908+908=368+386+386+863=485+485+485+548
[download]

And then I went D'Oh!. I should have been allowing up to 6 numbers and not allowing duplicates. So the inner loops got rather complicated:

for my $i ( 0..$#p ) {
  for my $j ( $i+1..$#p ) {
     $h{$p[$i]+$p[$j]} .= "=$p[$i]+$p[$j]";
     for my $k ( $j+1..$#p ) {
        $h{$p[$i]+$p[$j]+$p[$k]} .= "=$p[$i]+$p[$j]+$p[$k]";
        for my $l ( $k+1..$#p ) {
           $h{$p[$i]+$p[$j]+$p[$k]+$p[$l]}
              .= "=$p[$i]+$p[$j]+$p[$k]+$p[$l]";
           for my $m ( $l+1..$#p ) {
              $h{$p[$i]+$p[$j]+$p[$k]+$p[$l]+$p[$m]}
                 .= "=$p[$i]+$p[$j]+$p[$k]+$p[$l]+$p[$m]";
              for my $n ( $m+1..$#p ) {
                 $h{$p[$i]+$p[$j]+$p[$k]+$p[$l]+$p[$m]+$p[$n]}
                    .= "=$p[$i]+$p[$j]+$p[$k]+$p[$l]+$p[$m]+$p[$n]";
              }
           }
        }
     }
  }
}
[download]

and so I thought I'd turn it into a iterator similar to how I do things like (tye)Re: getting my neighbours in an N-dimensional space so that I could play with 4-digit numbers etc. without having to change the code, adding more loops and more $z, $w, $v, etc. variables.

But this one-off code had just been so easy to write. Making an iterator was going to be a bit tricky... I should write something to make writing the iterator nearly as easy as the one-off code...

This resulted in what I think is perhaps the neatest 30-odd lines of Perl code that I've ever written (but the blush will surely come off the rose after a bit of time passes).

This code lets you write arbitrarilly nested loops so that you can switch between having loops nested 6 deep or nested 4 deep without modifying any code. I think I'll upload it to CPAN as Algorithm::Loops (or Algorithm::NestedLoops) before long.

sub nestedLoops {
    my( $loops, $params )= @_;
    my $code= $params && $params->{Code};
    my @list;
    my $when= $params && $params->{OnlyWhen}
        ||  sub { @_ == @$loops };
    my $i= -1;
    my @idx;
    my @vals= @$loops;

    my $iter= sub {
        while( 1 ) {
            # Prepare to append one more value:
            if(  $i < $#$loops  ) {
                $idx[++$i]= -1;
                $vals[$i]= $loops->[$i]->(@list)
                    if  'CODE' eq ref $loops->[$i];
            }
            # Increment furthest value, chopping if done there:
            while(  @{$vals[$i]} <= ++$idx[$i]  ) {
                # Return if all done:
                return   if  --$i < 0;
                pop @list;
            }
            $list[$i]= $vals[$i][$idx[$i]];
            if(  ! ref $when  ||  $when->( @list )  ) {
                return @list;
            }
        }
    };
    return $iter   if  ! $code;
    while(  $iter->()   ) {
        $code->( @list );
    }
}
[download]

and you use it like so (showing both how to use it to get an iterator and how to use it with a call-back):

    my $digs= 3;
    my $fact= 1;
    $fact *= $_   for  2..$digs;

    my %h;
    my $getDigits= nestedLoops( [
        [0..9],
        ##[1..9],
        ( sub { [ $_[-1] .. 9 ] } ) x ($digs-1),
        ##( sub { [ $_[-1]+1 .. 9 ] } ) x ($digs-1),
    ] );
    my @list;
    while(  @list= $getDigits->()  ) {
        my @p;
        do {
            push @p, join "", @list;
        } while(  nextPermute( @list )  );
        nestedLoops(
            [
                [0..$#p],
                ( sub { [ $_[-1]+1 .. $#p ] } ) x ($fact-1),
            ],
            {
                OnlyWhen => 1,
                Code => sub {
                    my $expr= join "+", @p[@_];
                    my $noOct= $expr;
                    $noOct =~ s/(?<!\d)0+(\d)/$1/g;
                    ## $expr= "()"   if  @_ < 6;
                    $h{eval $noOct} .= "=$expr";
                },
            },
        );
    }

    ##for my $k ( sort { length($h{$a}) <=> length($h{$b})
    ##    || $a <=> $b } keys %h ) {
    for my $k ( sort { $a <=> $b } keys %h ) {
        print "$k$h{$k}\n"
            if  1990 < $k and $k < 2010;
            ##if  $h{$k} =~ /\d/  &&  index($h{$k},"()") < 0;
    }
[download]

with parts of the code that you might want to swap in (to find "interesting" things) commented with "##".

And, yes, I did find exactly one "good" solution for 2003. With the code provided, you can too.

I think artist should go back to the person who provided this puzzle and offer a counter puzzle: I wanted to give you this puzzle using a number other than 2003 but make it as hard as possible while still only using 3-digit numbers in the solution. I came up with exactly two candidates to replace 2003. What were they? (:

- tye

¹ I've had math teachers get mildly annoyed when "math" is used when "arithmatic" is more appropriate, hence the quotes.

In reply to Coming soon: Algorithm::Loops by tye

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


Welcome to the Monastery
	PerlMonks