[SPOILER] Perl 'Expert' Quiz-of-the-Week #8

well, I didn't look at the other solutions yet, but I thought my
approach might be interesting.  It seems to work, and work fast, but I
seem to run into a problem in the more difficult cases.  Now, I expect
things like G(19) to take longer, but for some reason that I can't quite
figure out, they actually hang my machine?  Could be that I'm out of
memory.

Perhaps I'll try rewriting it to use a disk based array, instead of a
memory one, see if that works better.

Anyway, here's the current revision.  I would really appreciate any
comments and suggestions for improvment.

-- 


#!/usr/bin/perl 

use strict;

my %primes;
my %factor_cache;

for (1..18) {
  print "G($_) = ";
  print scalar &Graham($_);
  print "\n";
}

sub Graham {
  my ($num) = @_;

  # the mail datastructure - each element of the array is a possible solution.  
First element
  # is a list of numbers we multiply.  The second element is an array of 
factors of all these
  # elements
  my @options = ( [ 
                    [ $num ] , 
                    &factor($num) 
                  ] );
  my $last_tested = -1;
  my $solution;

  while (not ref($solution = &is_square($last_tested, \@options, $solution))) {
    $num++;
    my @new_options;
    $last_tested = $#options;

    # find new options - append the current number to each option, but as a new 
option, keeping
    # the old one as well.
    my $factor = $factor_cache{$num} || ($factor_cache{$num} = &factor($num));
    next if &is_square(0, [ $factor ], undef);
    foreach (@options) {
      push @new_options, [ 
                          [ @{$_->[0]}, $num ] ,
                          &add_list($_->[1], $factor)
                        ];
    }
    push @options, @new_options;
  }

  return wantarray ? @{$solution->[0]->[0]} : $solution->[0]->[0]->[-1];
}

sub is_square {
  my ($start_index, $options, $last_fail) = @_;
  my $failed_factor = undef;
  # check possible options, starting from $start_index.  an options is the 
actual
  # solution if all the factors are even - means the product is a square.

  foreach my $index ($start_index + 1 .. $#$options) {
    next if defined $last_fail and $options->[$index]->[1]->[$last_fail] % 2;
    my $is_square = 1;
    foreach my $factor (@{$options->[$index]->[1]}) {
      next unless defined $factor;
      if ($factor % 2) { # you lose - it's an odd number
        $is_square = 0; 
        last;
      }
    }
    return [ $options->[$index] ] if $is_square;
  }

  return $failed_factor;
}

sub add_list {
  my ($l1, $l2) = @_;
  # utility function that just adds two lists.

  if ($#$l1 < $#$l2) {
    ($l1, $l2) = ($l2, $l1);
  }

  my $res = [ @$l1 ];
  $res->[$_] += $l2->[$_] for 0 .. $#$l2;

  return $res;
}

sub factor {
  my $num = shift;
  # find all the factors of a given number.
 
  my $orig_num = $num;
  my $prime = 2;
  my $factors;

  while ($num > 1) {
    until ($num % $prime) {
      $factors->[$prime]++;
      $num = $num / $prime;
    }

    if ($num > 1) { # we haven't found all the factors yet
      if (exists $primes{$prime} and defined $primes{$prime}) {
        $prime = $primes{$prime};
      } else { # we're out of cached primes, need to find more.
        my $cur_prime = $prime;
        my $is_prime = 0;
        my $sqrt = sqrt($num);
  
        until ($is_prime) {
          $prime++;
          $is_prime = 1;
          foreach (sort keys %primes) {
            last if $_ >= $sqrt;
            $is_prime = 0, last unless $prime % $_;
          }
        }

        $primes{$cur_prime} = $prime;
        $primes{$prime} = undef;
      }
    }
  }

  return $factors;
}

-- 
Dan Boger
dan-rlx3YLNxYWXQT0dZR+AlfA@xxxxxxxxxxxxxxxx