#!perl -w # # a script for solving simple roadblocks levels # http://www.freeaddictinggames.com/?id=340&req=givegame # # TILES # ------------------------ # u,n,],[ = goals # X = wall # 0 = ball # # all other characters represent whitespace # # FUTURE TILES? # ------------------------ # <,>,v,^ = one way # 1,2 = pairs of teleporters # use strict; use Data::Dumper; my @raw; # lvl 1 $raw[0] = " XXX "; $raw[1] = " X ] "; $raw[2] = " X "; $raw[3] = " "; $raw[4] = " X "; $raw[5] = "0 X "; $raw[6] = " XXX "; # lvl 2 $raw[0] = "------n-------"; $raw[1] = "--------------"; $raw[2] = "-----------XXX"; $raw[3] = "-----X--------"; $raw[4] = "-----X--------"; $raw[5] = "XX---X-------X"; $raw[6] = "X------------X"; $raw[7] = "X------0-----X"; $raw[8] = "X-----------XX"; $raw[9] = "--------------"; $raw[10] = "--------------"; $raw[11] = "-X------------"; $raw[12] = "-X------------"; # lvl 4 $raw[0] = "-----X--------------"; $raw[1] = "-X-------XXX--------"; $raw[2] = "--------------------"; $raw[3] = "-----------------X--"; $raw[4] = "---------------XXX--"; $raw[5] = "--XXX-----0[-------X"; $raw[6] = "----X-X------------X"; $raw[7] = "--------------XX-X--"; $raw[8] = "-----------------X--"; $raw[9] = "-----------------XX-"; $raw[10] = "--X---X----------X--"; $raw[11] = "X-XXX---XX-------X--"; $raw[12] = "X-------------------"; $raw[13] = "X---------X---------"; $raw[14] = "----------X--X--XX--"; # # first, build the map in memory # my $startx = 0; my $starty = 0; my @map; my @winners; my $sizex = 0; my $sizey = 0; for my $line(@raw){ $sizex = length($line) if length($line) > $sizex; if ($line =~ m/^(.*)0/){ $startx = length($1); $starty = scalar(@map); } while ($line =~ m/^(.*)[\[\]nu]/g){ my $winx = length($1); my $winy = scalar(@map); push @winners, "$winx-$winy"; } $line =~ s/0/ /; push @map, [split //, $line]; } $sizey = scalar(@map); my %moves; $moves{"$startx-$starty"} = ''; # # for each position currently in $moves, calculate all possible # moves from there and store new solution to that position # for(1..10){ # only calc up to 10 moves incase we run away for my $pos(keys %moves){ $pos =~ m/^(\d+)-(\d+)$/; my $x = $1; my $y = $2; # up my $y2 = &find_stop_up($x, $y); if ($y2 != $y){ if (!$moves{"$x-$y2"}){ $moves{"$x-$y2"} = $moves{"$x-$y"}.'u'; } } # down $y2 = &find_stop_down($x, $y); if ($y2 != $y){ if (!$moves{"$x-$y2"}){ $moves{"$x-$y2"} = $moves{"$x-$y"}.'d'; } } # left my $x2 = &find_stop_left($x, $y); if ($x2 != $x){ if (!$moves{"$x2-$y"}){ $moves{"$x2-$y"} = $moves{"$x-$y"}.'l'; } } # right $x2 = &find_stop_right($x, $y); if ($x2 != $x){ if (!$moves{"$x2-$y"}){ $moves{"$x2-$y"} = $moves{"$x-$y"}.'r'; } } } # found any solutions yet? for my $pos(@winners){ if ($moves{$pos}){ print "solution: $moves{$pos}\n"; exit; } } print '.'; } # # subs to advance the ball # sub find_stop_up { my ($x, $y) = @_; my $y2 = $y; while ($y2>=0){ $y2--; if ($map[$y2][$x] =~ m/[Xu\[\]]/){ return $y2+1; } if ($map[$y2][$x] eq 'n'){ return $y2; } } return $y; } sub find_stop_down { my ($x, $y) = @_; my $y2 = $y; while ($y2<$sizey-2){ $y2++; if ($map[$y2][$x] =~ m/[Xn\[\]]/){ return $y2-1; } if ($map[$y2][$x] eq 'u'){ return $y2; } } return $y; } sub find_stop_right { my ($x, $y) = @_; my $x2 = $x; while ($x2<$sizex-1){ $x2++; if ($map[$y][$x2] =~ m/[Xun\[]/){ return $x2-1; } if ($map[$y][$x2] eq ']'){ return $x2; } } return $x; } sub find_stop_left { my ($x, $y) = @_; my $x2 = $x; while ($x2>=0){ $x2--; if ($map[$y][$x2] =~ m/[Xun\]]/){ return $x2+1; } if ($map[$y][$x2] eq '['){ return $x2; } } return $x; }