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