0: ## Yes, I know it's been done before.  But has it been done this way?
1: 
2: # maze solver - solves a maze (shortest path) from a file or stdin
3: #
4: # Takes mazes with their headers in the format:
5: # Maze #. 1,1-8,8
6: # (without the initial '# ')
7: # (grid with # being wall and . being floor, entrance at (1,1), exit at (8,8))
8: #
9: # Note that movement cannot occur diagonally, and that the maze wraps
10: # around, so that the top is adjacent to the bottom and the left side
11: # is adjacent to the right.  Put walls there if you don't want that.
12: # The top left corner is (0, 0).
13: # Also note that in the maze file, all whitespace is ignored.
14: #
15: # Prints out the route in the format (row, col) (row, col) ... inclusive of entrance and exit.
16: # If no route exists, exits with code 1 and prints "No route found."
17: 
18: #!/usr/bin/perl -w
19: use strict;
20: 
21: my (@maze, $wall, $floor, @in, @out);
22: 
23: chomp ($_ = <>);
24: tr/ \n\t\f//d;
25: m<^Maze(.)(.)(\d+),(\d+)-(\d+),(\d+)$> ?
26:     (($wall, $floor, @in[0,1], @out[0,1]) =
27:      ($1, $2, $3, $4, $5, $6)) : die "Invalid maze header; stopped";
28: 
29: while (<>)
30: {
31:     chomp;
32:     tr/ \t\n\f//d;
33:     my @F = split//;
34:     push @maze, [ ];
35:     foreach (@F)
36:     {
37: 	($_ eq $wall) and push @ {$maze[-1]}, [ 0, 0 ];
38: 	($_ eq $floor) and push @ {$maze[-1]}, [ 1, 0 ];
39: 	($_ ne $wall and
40: 	 $_ ne $floor) and die "Unrecognized character: \'$_\'; stopped";
41:     }
42: }
43: 
44: (grep { scalar @$_ != scalar @ {$maze[0]} } @maze) and
45:     die "Number of columns not the same in every row; stopped";
46: 
47: my ($rows, $cols) = (scalar @maze, scalar @ {$maze[0]});
48: $maze[$in[0]][$in[1]][0] = 0;
49: $maze[$in[0]][$in[1]][1] = 1;
50: 
51: for (;;)
52: {
53:     if ($maze[$out[0]][$out[1]][1])
54:     {
55: 	my @sol = ();
56: 	my (@c) = ($out[0], $out[1]);
57: 	while ($c[0] != $in[0] or $c[1] != $in[1])
58: 	{
59: 	    push @sol, [ @c ];
60: 	    (@c) = ($maze[$c[0]][$c[1]][1][0],
61: 		    $maze[$c[0]][$c[1]][1][1]);
62: 	}
63: 	push @sol, [ $in[0], $in[1] ];
64: 	@sol = reverse @sol;
65: 	foreach (@sol)
66: 	{
67: 	    print "($$_[0], $$_[1]) ";
68: 	}
69: 	print "\n";
70: 	exit 0;
71:     }
72: 	
73:     my ($any) = (0);
74:     
75:     foreach my $row (0..($rows-1))
76:     {
77: 	foreach my $col (0..($cols-1))
78: 	{
79: 	    next if $maze[$row][$col][0];
80: 	    next unless $maze[$row][$col][1];
81: 
82: 	    foreach my $rc ([ $row, $col+1 ],
83: 			    [ $row+1, $col ],
84: 			    [ $row, $col-1 ],
85: 			    [ $row-1, $col ])
86: 	    {
87: 		$maze[$$rc[0]][$$rc[1]][0] && !$maze[$$rc[0]][$$rc[1]][1]
88: 		    and ($maze[$$rc[0]][$$rc[1]][0] = 0,
89: 			 $maze[$$rc[0]][$$rc[1]][1] = [ $row, $col ],
90: 			 $any = 1);
91: 	    }
92: 	}
93:     }
94:     if ($any == 0)
95:     {
96: 	print "No route found.\n";
97: 	exit 1;
98:     }
99: }