andromeda:davidj sums > cat sums.pl
#!/usr/bin/perl

# puzzles parameters
my $dim = $ARGV[0];
my $coverage = $ARGV[1];
# creation flags
my ($finished,$create_attempts,$total_locs,$num_filled) = (0,0,0,0);
# left column and top row totals
my (@acr_ar, @down_ar) = ((), ());
# hashes used to test for connected graph
my (%list, %visited);
# hashes to track sequence information
my (%across, %down, %intersect);
# arrays used to hold order of longest sequences in each direction
my (@across_order, @down_order);
# main grid
my @g;

# since this uses a brute force method
# there is a chance of failure. Try 5 and bail
until($finished || $create_attempts == 5) {
    my ($complete,$attempts) = (0,0);
    until ($complete) {
        @g = ();
        &init_grid() && &fill_grid();
        next unless &check_coverage() && &check_grid();
        $complete = &test_connected();
    }
    &set_across() && &set_down() && &set_intersect();
    $finished = &set_numbers() until $finished || $attempts++ == 5;
    $create_attempts++;
}
if($finished) {
    @down_ar = map {' ' x 7} (1 .. $dim);
    @acr_ar = map {' ' x 7} (1 .. $dim);
    &set_totals();
    &display_puzzle();
    print "\n\n";
    &display_solution();
} else {
    print "could not create puzzle\n";
}

# initial grid to all '-'
sub init_grid() {
    for(my $i = 0; $i < $dim; $i++) {
        for(my $j = 0; $j < $dim; $j++) {
            $g[$i][$j] = '-';
        }
    }
    return 1;
}

# fill the grid with '@' markers that will be later filled with numbers
sub fill_grid() {
    my $c = $dim;
    for(my $i = 0; $i < $dim-1; $i++) {
        for(my $j = 0; $j < $c-1; $j++) {
            if (int(rand(4)) % 4 == 0) {
                $g[$i][$j] = $g[$i][$j+1] = $g[$i+1][$j] = $g[$i+1][$j+1] = '@';
                my $ni = ($dim - 2) - $i;
                my $nj = ($dim - 2) - $j;
                $g[$ni][$nj] = $g[$ni][$nj+1] = $g[$ni+1][$nj] = $g[$ni+1][$nj+1] = '@';
            } else {
                $g[$i][$j] = $g[($dim-1)-$i][($dim-1)-$j] = "-" unless $g[$i][$j] eq '@';
            }
        }
        $c--;
    }
    return 1;
}

# make sure the coverage threshold is met (grab total coverage at same time)
sub check_coverage () {
    $total_locs = 0;
    for(my $i = 0; $i < $dim; $i++) {
        for(my $j = 0; $j < $dim; $j++) {
            $total_locs++ if $g[$i][$j] eq "@";
        }
    }
    return ($total_locs / ($dim * $dim)) >= $coverage ? 1 : 0;
}

# make sure there are no sequences greater than length 9
# we need to do this since one of the constraints of the
# puzzle is that the numbers 1-9 cannot be repeated in
# a sequence
sub check_grid() {
    my ($countH, $countV) = (0,0);
    for(my $i = 0; $i < $dim; $i++) {
        for(my $j = 0; $j < $dim; $j++) {
            $g[$i][$j] eq "@" ? $countH++ : ($countH = 0);
            $g[$j][$i] eq "@" ? $countV++ : ($countV = 0);
            return 0 if ($countH > 9 or $countV > 9);
        }
        $countH = $countV = 0;
    }
    return 1;
}

# depth first search to test for connectivity
sub DFS () {
    my $v = shift;
    my @links;
    $visited{$v} = "true";
    @links = sort {$a <=> $b} (@{ $list{$v} });
    foreach my $link ( @links ) {
        &DFS($link) if $visited{$link} eq "false";
    }
}

# self-explanatory
sub display_solution () {
    my $num = ($dim+1) * 8;
    print "\n" . "-" x $num . "\n";
    print '|       ';
    for(my $i = 0; $i <= $dim; $i++) {
        print '|' . $acr_ar[$i];
    }
    print "\n" . "-" x $num . "\n";
    for(my $i = 0; $i < $dim; $i++) {
        print '|' . $down_ar[$i] . '|';
        for(my $j = 0; $j < $dim; $j++) {
            printf("%8s", $g[$i][$j] . '  |');
        }
        print  "\n" . '-' x $num . "\n";
    }
}

# self-explanatory
sub display_puzzle() {
    my $num = ($dim+1) * 8;
    print "\n" . "-" x $num . "\n";
    print '|       ';
    for(my $i = 0; $i <= $dim; $i++) {
        print '|' . $acr_ar[$i];
    }
    print "\n" . "-" x $num . "\n";
    for(my $i = 0; $i < $dim; $i++) {
        print '|' . $down_ar[$i] . '|';
        for(my $j = 0; $j < $dim; $j++) {
            if($g[$i][$j] =~ m/[:-]/) {
                printf("%8s", $g[$i][$j] . '  |');
            } else {
                printf("%8s", ' ' . '  |');
            }
        }
        print  "\n" . '-' x $num . "\n";
    }
}

# get the list of numbers that are not used in the
# row and column that intersect the current location
sub get_unused() {
    my ($aref,$bref,$dref) = @_;
    my (@ar, %seen);
    foreach my $elm ( @{$aref},@{$bref} ) {
        $seen{$elm} = 1;
    }
    foreach my $elm ( @{$dref} ) {
        push @ar, $elm unless $seen{$elm};
    }
    return @ar;
}

# create list of all connecting locations.
# locations are connected if an adjacent n,s,e, or w
# location also has a number in it
sub make_list () {
    %list = ();
    for(my $i = 0; $i < $dim; $i++) {
        for(my $j = 0; $j < $dim; $j++) {
            if($g[$i][$j] eq "@") {
                push(@{ $list{($i*$dim)+$j} }, (($i-1)*$dim)+$j) if ($i>0 and ($g[$i-1][$j] eq '@'));
                push(@{ $list{($i*$dim)+$j} }, (($i+1)*$dim)+$j) if $g[$i+1][$j] eq "@";
                push(@{ $list{($i*$dim)+$j} }, ($i*$dim)+($j-1)) if ($j>0 and ($g[$i][$j-1] eq '@'));
                push(@{ $list{($i*$dim)+$j} }, ($i*$dim) + ($j+1)) if $g[$i][$j+1] eq "@";
            }
        }
    }
    return 1;
}

# get a hash of all row sequence starting locations and all
# the adjacent locations that make up the sequence.
# also get the size of the sequence. We use this later
# in determining which sequences to fill first
sub set_across () {
    %across = ();
    for(my $i = 0; $i < $dim; $i++) {
        for(my $j = 0; $j < $dim; $j++) {
            if($g[$i][$j] eq "@") {
                my @locs = ();
                my $start = ($i * $dim) + $j;
                push(@locs, ($i * $dim) + $j++) while($g[$i][$j] eq "@");
                $across{$start}->{locs} = [ @locs ];
            }
        }
    }
    @across_order =  reverse sort { scalar(@{ $across{$a}->{locs} }) <=> scalar(@{ $across{$b}->{locs} }) } keys %across;
    return 1;
}

# same as set_across, except for columnar sequences
sub set_down () {
    %down = ();
    for(my $j = 0; $j < $dim; $j++) {
        for(my $i = 0; $i < $dim; $i++) {
            if($g[$i][$j] eq "@") {
                my @locs = ();
                my $start = ($i * $dim) + $j;
                push(@locs, ($i++ * $dim) + $j) while($g[$i][$j] eq "@");
                $down{$start}->{locs} = [ @locs ];
            }
        }
    }
    @down_order =  reverse sort { scalar(@{ $down{$a}->{locs} }) <=> scalar(@{ $down{$b}->{locs} }) } keys %down;
    return 1;
}

# determine the across and down sequences that intersect
# at each location to be filled. This will be needed to
# guarantee each sequence contains unique numbers
sub set_intersect () {
    my ($aw, $dw);
    %intersect = ();
    for(my $i = 0; $i < $dim; $i++) {
        for(my $j = 0; $j < $dim; $j++) {
            if($g[$i][$j] eq "@") {
                my $loc = ($i * $dim) + $j;
                foreach my $apos (keys %across) {
                    if(grep { $_ == $loc }  @{ $across{$apos}->{locs} }) {
                        $aw = $apos;
                        last;
                    }
                }
                foreach my $dpos (keys %down) {
                    if(grep { $_ == $loc }  @{ $down{$dpos}->{locs} }) {
                        $dw = $dpos;
                        last;
                    }
                }
                $intersect{$loc} = [$aw, $dw];
            }
        }
    }
    return 1;
}

# fill the sequences with unique numbers
sub set_numbers () {
    my ($cur, $cur_a, $cur_d, $cur_loc, $dir, $aw, $dw, $nd, $nl);
    my (@grid_locs, @unused);
    my @digits = (1 .. 9);

    #initialize variables
    @grid_locs = @unused = ();
    $num_filled = 0;

    # use copies of data structures since we may need to
    # attempt this more than once
    @tmp_grid = @g;
    %tmp_across = %across;
    %tmp_down = %down;
    @tmp_across_order = @across_order;
    @tmp_down_order = @down_order;

    # we loop until all locations have been filled
    while( $total_locs != $num_filled) {
        # get the sequence with the greatest number of unfilled locations.
        # we do this because it will be the hardest to fill
        @grid_locs = ();
        while(1) {
            if(scalar(@{ $tmp_across{$tmp_across_order[0]}->{locs} }) >= scalar(@{ $tmp_down{$tmp_down_order[0]}->{locs} }) ) {
                $cur = shift @tmp_across_order;
                ($nl, $nd) = ( scalar(@{ $tmp_across{$cur}->{locs} }), scalar(@{ $tmp_across{$cur}->{nums} }) );
                $dir = "a";
            } else {
                $cur = shift @tmp_down_order;
                ($nl, $nd) = (scalar(@{ $tmp_down{$cur}->{locs} }), scalar(@{ $tmp_down{$cur}->{nums} }) );
                $dir = "d";
            }
            last if $nl > $nd;
        }
        # get array of grid locations of retreived sequence to place numbers in
        @grid_locs = ($dir eq "a" ? @{ $tmp_across{$cur}->{locs} } : @{ $tmp_down{$cur}->{locs} });
        #iterate over the locations and place numbers
        while(scalar(@grid_locs) > 0) {
            @unused = ();
            $cur_loc = shift @grid_locs;
            # if the current location is already filled we can skip it
            ($cur_a, $cur_d) = ( (int($cur_loc / $dim)), ($cur_loc % $dim) );
            next if $tmp_grid[$cur_a][$cur_d] ne "@";
            # get the row and column sequences that intersect at this location
            # we need this information becuase of the unique number constraint
            # get the numbers that have NOT been used in either sequence.
            # fail if all numbers have been used
            ($aw, $dw) = (@{ $intersect{$cur_loc} });
            @unused = &get_unused(\@{$tmp_across{$aw}->{nums}}, \@{$tmp_down{$dw}->{nums}}, \@digits);
            return 0 if scalar(@unused) == 0;
            $number = $unused[ int(rand(scalar(@unused))) ];
            # store number in grid location.
            # also, add to the list of numbers used and add to running totals
            $tmp_grid[$cur_a][$cur_d] = $number;
            push( @{ $tmp_across{$aw}->{nums} }, $number);
            $tmp_across{$aw}->{total} += $number;
            push( @{ $tmp_down{$dw}->{nums} }, $number);
            $tmp_down{$dw}->{total} += $number;
            $num_filled++;
        }
    }

    # if we get this far then all is good, so copy back
    @g = @tmp_grid;
    %across = %tmp_across;
    %down = %tmp_down;
    @across_order = @tmp_across_order;
    @down_order = @tmp_down_order;
    return 1;
}

# used for display purposes. enters the sequence totals on the grid.
sub set_totals () {
    foreach my $key (sort keys %down) {
        my ($x,$y) = ( int($key/$dim) - 1, $key % $dim );
        if($key < $dim) {
            $acr_ar[$key] = ' ' x (4 - length($down{$key}->{total})) . $down{$key}->{total} . ':  ';
        }
        if($x >= 0) {
            $g[$x][$y] = $down{$key}->{total} . ':';
        }
    }
    foreach my $key (sort keys %across) {
        my ($x,$y) = ( int($key/$dim), ($key % $dim) -1 );
        if ($y >= 0) {
            $g[$x][$y] =~ s/-//g;
            $g[$x][$y] .= ":" . $across{$key}->{total};
            $g[$x][$y] =~ s/::/:/;
        } else {
            $down_ar[$x] = '  :' . $across{$key}->{total} . ' ' x (4 - length($across{$key}->{total}));
        }
    }
}

# one constraint of the puzzle is that it must be 'connected'
# connected means that each square containing a number is
# part of an across sequence and down sequence
# uses dfs to test for connectivity
sub test_connected () {
    my $searches = 0;
    my @vertices = ();
    &make_list();
    @vertices = sort {$a <=> $b} (keys %list);
    %visited = map { $_ => "false" } @vertices;
    foreach my $vertex (@vertices) {
        if($visited{$vertex} eq "false") {
            $searches++;
            &DFS($vertex);
        }
    }
    return $searches > 1 ? 0 : 1;
}


##</code><code>##

andromeda:davidj sums > perl sums.pl 7 .6

----------------------------------------------------------------
|       |  10:  |  23:  |       |  12:  |  31:  |       |       |
----------------------------------------------------------------
|  :12  |       |       | 37:9  |       |       |  36:  |   9:  |
----------------------------------------------------------------
|  :30  |       |       |       |       |       |       |       |
----------------------------------------------------------------
|       |  :36  |       |       |       |       |       |       |
----------------------------------------------------------------
|       | 8:14  |       |       |19:14  |       |       |    -  |
----------------------------------------------------------------
|  :25  |       |       |       |       |       |       |  11:  |
----------------------------------------------------------------
|  :39  |       |       |       |       |       |       |       |
----------------------------------------------------------------
|       |    -  |  :10  |       |       |   :7  |       |       |
----------------------------------------------------------------

SOLUTION

----------------------------------------------------------------
|       |  10:  |  23:  |       |  12:  |  31:  |       |       |
----------------------------------------------------------------
|  :12  |    9  |    3  | 37:9  |    3  |    6  |  36:  |   9:  |
----------------------------------------------------------------
|  :30  |    1  |    4  |    7  |    2  |    3  |    8  |    5  |
----------------------------------------------------------------
|       |  :36  |    2  |    8  |    7  |    9  |    6  |    4  |
----------------------------------------------------------------
|       | 8:14  |    5  |    9  |19:14  |    5  |    9  |    -  |
----------------------------------------------------------------
|  :25  |    5  |    1  |    6  |    2  |    7  |    4  |  11:  |
----------------------------------------------------------------
|  :39  |    3  |    8  |    5  |    9  |    1  |    7  |    6  |
----------------------------------------------------------------
|       |    -  |  :10  |    2  |    8  |   :7  |    2  |    5  |
----------------------------------------------------------------