Don't understand where is problem? Help me please someone!
Here my code...

{$Apptype console}

const
 dx : array [1..4]of longint = (1 , -1 , 0 , 0);
 dy : array [1..4]of longint = (0 , 0 , -1 , 1);


var
 a : array [0..5 , 0..5] of char;
 was : array [0..5,0..5] of boolean;
 i , j : longint;
 s : string;
 n : longint;

Function Same(rem : longint; x , y : longint) : boolean;
var i : longint;
    ok : boolean;
 begin
   if rem = n + 1 then Same := true else

    if was[x, y] then Same := false else

     begin

      ok := false;
      was[x , y] := true;

      if a[x , y] = s[rem] then
        for i := 1 to 4 do
         if Same(rem + 1, x + dx[i] , y + dy[i]) then ok := true;

      Same := ok;
      was[x , y] := false;
     end;
 end;

 Function check(s : string) : boolean;
 var ch  : boolean;
  begin
   ch := false;

   while s[1] = ' ' do delete(s , 1 , 1);
   while s[length(s)] = ' ' do delete(s , 1 , 1);

   n := length(s);
    for i:= 1 to 4 do
     for j:= 1 to 4 do
      if same(1 , i, j) then ch := true;

    check := ch;
  end;

Begin

 for i:= 0 to 5 do
  for j:= 0 to 5 do
   a[i, j] := '1';

 fillchar(was , sizeof(was) , false);


 for i:= 1 to 4 do
  begin

    for j:= 1 to 4 do
     read(a[i , j]);

    readln;
  end;


 readln(n);

  for i:= 1 to n do
   begin
    readln(s);
    if check(s)  then writeln(s,': YES') else writeln(s,': NO');
   end;


end.

while s[length(s)] = ' ' do delete(s , 1 , 1);
hmm... O.o What is it? It may be delete(s , 1 , length(s));

Change yuor programm for tests like this:
abra
adac
babr
arca
3
abracadabra
ababaab

ababaaba

Edited by author 29.03.2008 01:19