http://www.perlmonks.org?node_id=249979

Now you can write arbitrarilly-nested loops easily.

Today in the CB, artist proposed a "math"1 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}; }
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=...
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
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]"; } } } } } }
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 ); } }
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; }
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

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