#!perl -w # # a script for solving roadblocks levels # http://www.freeaddictinggames.com/?id=340&req=givegame # # version 2: support for one-ways and teleporters # # TILES # ------------------------ # u,n,],[ = goals # X = wall # 0 = ball # <,>,v,^ = one way # 1,2 = pairs of teleporters # # all other characters represent whitespace # 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--"; # lvl 16 $raw[0] = "---------------X--------"; $raw[1] = "------------n-----------"; $raw[2] = "---------X--------------"; $raw[3] = "-------------------X----"; $raw[4] = "-----------X------------"; $raw[5] = "--X-----X---------------"; $raw[6] = "----X---XXX-------------"; $raw[7] = "------X---------X-------"; $raw[8] = "---1----X-0-X----1------"; $raw[9] = "----X---------X---------"; $raw[10] = "----------X-------------"; $raw[11] = "-X-------->-----------XX"; $raw[12] = "---------X----------X---"; $raw[13] = "X----------------X------"; $raw[14] = "-----------X------------"; $raw[15] = "------------------X-----"; $raw[16] = "---------------X--------"; # # 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..100){ # only calc up to 100 moves incase we run away for my $pos(keys %moves){ $pos =~ m/^(\d+)-(\d+)$/; my $x = $1; my $y = $2; my ($x2, $y2); # up ($x2, $y2) = &find_stop_up($x, $y); &add_move($x, $y, $x2, $y2, 'u'); # down ($x2, $y2) = &find_stop_down($x, $y); &add_move($x, $y, $x2, $y2, 'd'); # left ($x2, $y2) = &find_stop_left($x, $y); &add_move($x, $y, $x2, $y2, 'l'); # right ($x2, $y2) = &find_stop_right($x, $y); &add_move($x, $y, $x2, $y2, 'r'); } # found any solutions yet? for my $pos(@winners){ if ($moves{$pos}){ print "\nsolution: $moves{$pos}\n"; exit; } } print '.'; } # # subs to advance the ball # sub find_stop_up { my ($x, $y) = @_; my ($x2, $y2) = @_; while ($y2>=0){ $y2--; if ($map[$y2][$x2] =~ m/[Xu\[\]<>v]/){ return ($x2, $y2+1); } if ($map[$y2][$x2] eq 'n'){ return ($x2, $y2); } if ($map[$y2][$x2] =~ m/([1-9])/){ ($x2, $y2) = &do_teleport($x2, $y2, $1); } } return ($x, $y); } sub find_stop_down { my ($x, $y) = @_; my ($x2, $y2) = @_; while ($y2<$sizey-2){ $y2++; if ($map[$y2][$x2] =~ m/[Xn\[\]<>\^]/){ return ($x2, $y2-1); } if ($map[$y2][$x2] eq 'u'){ return ($x2, $y2); } if ($map[$y2][$x2] =~ m/([1-9])/){ ($x2, $y2) = &do_teleport($x2, $y2, $1); } } return ($x, $y); } sub find_stop_right { my ($x, $y) = @_; my ($x2, $y2) = @_; while ($x2<$sizex-1){ $x2++; if ($map[$y2][$x2] =~ m/[Xun\[=0){ $x2--; if ($map[$y2][$x2] =~ m/[Xun\]>v\^]/){ return ($x2+1, $y2); } if ($map[$y2][$x2] eq '['){ return ($x2, $y2); } if ($map[$y2][$x2] =~ m/([1-9])/){ ($x2, $y2) = &do_teleport($x2, $y2, $1); } } return ($x, $y); } sub add_move{ my ($x, $y, $x2, $y2, $dir) = @_; unless ($x==$x2 && $y==$y2){ if (!$moves{"$x2-$y2"}){ $moves{"$x2-$y2"} = $moves{"$x-$y"}.$dir; } } } sub do_teleport { my ($x, $y, $id) = @_; for(my $iy=0; $iy<$sizey; $iy++){ for(my $ix=0; $ix<$sizex; $ix++){ unless ($x==$ix && $y==$iy){ if ($map[$iy][$ix] eq $id){ return ($ix, $iy); } } } } return ($x, $y); }