Return To The Other End

It was suggested in the comments that there was a better way to pass the history around, and the suggestion was correct. I tried Storable and was not able to make it do what I wanted, so I went with Clone.

The Revised Code

view plainprint?

1. #!/usr/bin/perl  
2.   
3. use Modern::Perl ;  
4. use Clone qw(clone) ;  
5. use subs qw{ solve_sudoku test_solution display_puzzle no_go_list } ;  
6.   
7. my @array ;  
8. my @test ;  
9. my $x = 0 ;  
10. my $debug = 0 ;  
11. my $outcount = 0 ;  
12.   
13. #READ IN DATA  
14. while ( my $line = <data> ) {  
15.     chomp $line ;  
16.     $line =~ s{\D}{ }mxg ;  
17.     my @line = split m{|}mx , $line ;  
18.     for my $y ( 0 .. 8 ) {  
19.         if ( $line[$y] =~ m{\d}mx ) { $array[$x][$y] = $line[$y] ; }  
20.         else {                        $array[$x][$y] = '' ; }  
21.         }  
22.     $x++ ;  
23.     }  
24.   
25. solve_sudoku( 0 , 0 , \@array ) ;  
26.   
27. #-------------------------------------------------------------------------------  
28. sub solve_sudoku {  
29.     my $x = shift ;     my $nx ;  
30.     my $y = shift ;     my $ny ;  
31.     my $history = shift ;  
32.     my $local = clone( $history ) ;  
33.     return if ! test_solution( $local ) ; #0 if fail  
34.     my $current = $$local[$x][$y] ;  
35.     $nx = $x ;  
36.     $ny = $y + 1 ;  
37.     if ( $ny > 8 ) {  
38.         $ny = 0 ;  
39.         $nx = $x + 1 ;  
40.         }  
41.     exit if !defined $nx ;  
42.     exit if !defined $ny ;  
43.     if ( $current =~ m{\d}mx ) { # current position is filled  
44.         solve_sudoku( $nx , $ny , $local ) ;  
45.         }  
46.     else { # current possition is empty ;  
47.         for my $v ( 1 .. 9 ) {  
48.             $$local[$x][$y] = $v ;  
49.             solve_sudoku( $nx , $ny , $local ) ;  
50.             }  
51.         }  
52.     }  
53. #-------------------------------------------------------------------------------  
54.   
55. #-------------------------------------------------------------------------------  
56. sub test_solution {  
57.     # If incomplete and wrong, return 0  
58.     # If incomplete and right, return 1  
59.     # If complete   and right, exit and display  
60.     my $ptr_array = shift ; #pointer to a potentially solved puzzle  
61.   
62.     {   # Horizontal  
63.         for my $x (0 .. 8 ) {  
64.             my %error ;  
65.             for my $y ( 0 .. 8 ) {  
66.                 my $val = $$ptr_array[$x][$y] ;  
67.                 if ( defined $val ) {  
68.                     next if $val =~ m{\D}mx ;  
69.                     $error{ $val }++ ;  
70.                     }  
71.                 }  
72.             for my $e ( sort keys %error ) {  
73.                 if ( $error{$e} > 1 && $e =~ m{\d}mx ) {  
74.                     $debug and say 'FAIL HORIZONTAL ' . $e ;  
75.                     return 0 ;  
76.                     }  
77.                 }  
78.             }  
79.         }  
80.   
81.     {   # Vertical  
82.         for my $y ( 0 .. 8 ) {  
83.             my %error ;  
84.             for my $x ( 0 .. 8 ) {  
85.                 my $val = $$ptr_array[$x][$y] ;  
86.                 if ( defined $val ) {  
87.                     next if $val =~ m{\D}mx ;  
88.                     $error{ $val }++ ;  
89.                     }  
90.                 }  
91.             for my $e ( sort keys %error ) {  
92.                 if ( $error{$e} > 1 && $e =~ m{\d}mx ) {  
93.                     $debug and say 'FAIL VERTICAL ' . $e ;  
94.                     return 0 ;  
95.                     }  
96.                 }  
97.             }  
98.         }  
99.   
100.     {   # blocks  
101.         my @range ;  
102.         $range[0][0] = 0 ;        $range[0][1] = 1 ;        $range[0][2] = 2 ;  
103.         $range[1][0] = 3 ;        $range[1][1] = 4 ;        $range[1][2] = 5 ;  
104.         $range[2][0] = 6 ;        $range[2][1] = 7 ;        $range[2][2] = 8 ;  
105.   
106.         for my $a ( 0 ..2 ) {  
107.             for my $b ( 0 ..2 ) {  
108.                 my @x = $range[$a] ;  
109.                 my @y = $range[$b] ;  
110.                 my %error ;  
111.                 for my $i ( 0 .. 2 ) {  
112.                     for my $j ( 0 .. 2 ) {  
113.                         my $x = $range[$a][$i] ;  
114.                         my $y = $range[$b][$j] ;  
115.                         my $val = $$ptr_array[$x][$y] ;  
116.                         if ( defined $val ) {  
117.                             next if $val =~ m{\D}mx ;  
118.                             $error{ $val }++ ;  
119.                             }  
120.                         }  
121.                     }  
122.                 for my $e ( sort keys %error ) {  
123.                     if ( $error{$e} > 1 && $e =~ m{\d}mx ) {  
124.                         $debug and say 'FAIL BLOCK ' . $e ;  
125.                         return 0 ;  
126.                         }  
127.                     }  
128.                 }  
129.             }  
130.         }  
131.   
132.     {   # ALL GOOD  
133.         my $c = 0 ; #numberof numbers in array  
134.         for my $y ( 0 .. 8 ) {  
135.             for my $x ( 0 .. 8 ) {  
136.                 my $val = $$ptr_array[$x][$y] ;  
137.                 if ( defined $val && $val =~ m{\d}mx ) {  
138.                     $c++ ;  
139.                     }  
140.                 }  
141.             }  
142.         if ( $c == 81 ) {  
143.             say 'GOOD' ;  
144.             display_puzzle $ptr_array ;  
145.             exit ;  
146.             }  
147.         }  
148.     return 1 ;  
149.     }  
150. #-------------------------------------------------------------------------------  
151.   
152. #-------------------------------------------------------------------------------  
153. sub display_puzzle {  
154.     my $ptr_array = shift ; #pointer to a potentially solved puzzle  
155.     say '        -------------' ;  
156.     for my $x ( 0 .. 8 ) {  
157.         print '        ' ;  
158.         for my $y ( 0 .. 8 ) {  
159.             my $v = $$ptr_array[$x][$y] ;  
160.             if ( $v !~ m{\d}mx ) { $v = '_' ; }  
161.             print $v  ;  
162.             print '  ' if $y == 2 ;  
163.             print '  ' if $y == 5 ;  
164.             }  
165.         say '' ;  
166.         say '' if $x == 2 ;  
167.         say '' if $x == 5 ;  
168.         }  
169.     say '        -------------  ' ;  
170.     say '' ;  
171.     }  
172. #-------------------------------------------------------------------------------  
173.   
174.   
175. exit 0 ;  
176. #===============================================================================  
177.   
178. __DATA__  
179. 9__3____6  
180. _8______7  
181. __52_89__  
182. __8__4_73  
183. _9_____4_  
184. 76_1__2__  
185. __78_14__  
186. 1______5_  
187. 8____9__1  
188.   
189. </data>  

#!/usr/bin/perl

use Modern::Perl ;
use Clone qw(clone) ;
use subs qw{ solve_sudoku test_solution display_puzzle no_go_list } ;

my @array ;
my @test ;
my $x = 0 ;
my $debug = 0 ;
my $outcount = 0 ;

#READ IN DATA
while ( my $line =  ) {
    chomp $line ;
    $line =~ s{\D}{ }mxg ;
    my @line = split m{|}mx , $line ;
    for my $y ( 0 .. 8 ) {
        if ( $line[$y] =~ m{\d}mx ) { $array[$x][$y] = $line[$y] ; }
        else {                        $array[$x][$y] = '' ; }
        }
    $x++ ;
    }

solve_sudoku( 0 , 0 , \@array ) ;

#-------------------------------------------------------------------------------
sub solve_sudoku {
    my $x = shift ;     my $nx ;
    my $y = shift ;     my $ny ;
    my $history = shift ;
    my $local = clone( $history ) ;
    return if ! test_solution( $local ) ; #0 if fail
    my $current = $$local[$x][$y] ;
    $nx = $x ;
    $ny = $y + 1 ;
    if ( $ny > 8 ) {
        $ny = 0 ;
        $nx = $x + 1 ;
        }
    exit if !defined $nx ;
    exit if !defined $ny ;
    if ( $current =~ m{\d}mx ) { # current position is filled
        solve_sudoku( $nx , $ny , $local ) ;
        }
    else { # current possition is empty ;
        for my $v ( 1 .. 9 ) {
            $$local[$x][$y] = $v ;
            solve_sudoku( $nx , $ny , $local ) ;
            }
        }
    }
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
sub test_solution {
    # If incomplete and wrong, return 0
    # If incomplete and right, return 1
    # If complete   and right, exit and display
    my $ptr_array = shift ; #pointer to a potentially solved puzzle

    {   # Horizontal
        for my $x (0 .. 8 ) {
            my %error ;
            for my $y ( 0 .. 8 ) {
                my $val = $$ptr_array[$x][$y] ;
                if ( defined $val ) {
                    next if $val =~ m{\D}mx ;
                    $error{ $val }++ ;
                    }
                }
            for my $e ( sort keys %error ) {
                if ( $error{$e} > 1 && $e =~ m{\d}mx ) {
                    $debug and say 'FAIL HORIZONTAL ' . $e ;
                    return 0 ;
                    }
                }
            }
        }

    {   # Vertical
        for my $y ( 0 .. 8 ) {
            my %error ;
            for my $x ( 0 .. 8 ) {
                my $val = $$ptr_array[$x][$y] ;
                if ( defined $val ) {
                    next if $val =~ m{\D}mx ;
                    $error{ $val }++ ;
                    }
                }
            for my $e ( sort keys %error ) {
                if ( $error{$e} > 1 && $e =~ m{\d}mx ) {
                    $debug and say 'FAIL VERTICAL ' . $e ;
                    return 0 ;
                    }
                }
            }
        }

    {   # blocks
        my @range ;
        $range[0][0] = 0 ;        $range[0][1] = 1 ;        $range[0][2] = 2 ;
        $range[1][0] = 3 ;        $range[1][1] = 4 ;        $range[1][2] = 5 ;
        $range[2][0] = 6 ;        $range[2][1] = 7 ;        $range[2][2] = 8 ;

        for my $a ( 0 ..2 ) {
            for my $b ( 0 ..2 ) {
                my @x = $range[$a] ;
                my @y = $range[$b] ;
                my %error ;
                for my $i ( 0 .. 2 ) {
                    for my $j ( 0 .. 2 ) {
                        my $x = $range[$a][$i] ;
                        my $y = $range[$b][$j] ;
                        my $val = $$ptr_array[$x][$y] ;
                        if ( defined $val ) {
                            next if $val =~ m{\D}mx ;
                            $error{ $val }++ ;
                            }
                        }
                    }
                for my $e ( sort keys %error ) {
                    if ( $error{$e} > 1 && $e =~ m{\d}mx ) {
                        $debug and say 'FAIL BLOCK ' . $e ;
                        return 0 ;
                        }
                    }
                }
            }
        }

    {   # ALL GOOD
        my $c = 0 ; #numberof numbers in array
        for my $y ( 0 .. 8 ) {
            for my $x ( 0 .. 8 ) {
                my $val = $$ptr_array[$x][$y] ;
                if ( defined $val && $val =~ m{\d}mx ) {
                    $c++ ;
                    }
                }
            }
        if ( $c == 81 ) {
            say 'GOOD' ;
            display_puzzle $ptr_array ;
            exit ;
            }
        }
    return 1 ;
    }
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
sub display_puzzle {
    my $ptr_array = shift ; #pointer to a potentially solved puzzle
    say '        -------------' ;
    for my $x ( 0 .. 8 ) {
        print '        ' ;
        for my $y ( 0 .. 8 ) {
            my $v = $$ptr_array[$x][$y] ;
            if ( $v !~ m{\d}mx ) { $v = '_' ; }
            print $v  ;
            print '  ' if $y == 2 ;
            print '  ' if $y == 5 ;
            }
        say '' ;
        say '' if $x == 2 ;
        say '' if $x == 5 ;
        }
    say '        -------------  ' ;
    say '' ;
    }
#-------------------------------------------------------------------------------


exit 0 ;
#===============================================================================

__DATA__
9__3____6
_8______7
__52_89__
__8__4_73
_9_____4_
76_1__2__
__78_14__
1______5_
8____9__1

The main loop is much cleaner, and it works. Yay me! Yay readers! Yay Clone! Yay Perl! Next steps are to integrate this into a Sudoku maker, connect that via Ajax to my puzzle, and to to find good ways to input the puzzles in the first place.