Cod sursa(job #1377827)

Utilizator ttofi89Tofalvi Tamas ttofi89 Data 6 martie 2015 08:23:30
Problema Rj Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.56 kb
const irany:Array [1..2,1..8] of integer =((1,-1,0,0,1,-1,1,-1),(0,0,1,-1,1,1,-1,-1));
var r:array[0..101,0..101] of integer;
    ju:array[0..101,0..101] of integer;
    n,m:integer;
procedure beolv(var n,m:integer);
    var f:text;
        i,j:integer;
        c:char;
    begin
    assign(f,'rj.in');
    reset(f);
    readln(f,n,m);
    for i:=0 to n do begin
                     r[i,0]:=-1;
                     r[i,m+1]:=-1;
                     ju[i,0]:=-1;
                     ju[i,m+1]:=-1;
                     end;
    for i:=0 to m do begin
                     r[0,i]:=-1;
                     r[n+1,i]:=-1;
                     ju[0,i]:=-1;
                     ju[n+1,i]:=-1;
                     end;
    for i:=1 to n do
       for j:=1 to m+2 do
                      begin
                      read(f,c);
                      case c of ' ':begin
                                    r[i,j]:=0;
                                    ju[i,j]:=0;
                                    end;
                                'R':begin
                                    r[i,j]:=1;
                                    ju[i,j]:=0;
                                    end;
                                'J':begin
                                    r[i,j]:=0;
                                    ju[i,j]:=1;
                                    end;
                                'X':begin
                                    r[i,j]:=-1;
                                    ju[i,j]:=-1;
                                    end;
                      end;
                      end;
    end;

procedure romeofuss;
        var i,j,k,l:integer;
            mehet:boolean;
        begin
        k:=1;
        repeat
        mehet:=false;
        for i:=1 to n do
           for j:=1 to m do
                if r[i,j]=k then
                    for l:=1 to 8 do
                        if (r[i+irany[1,l],j+irany[2,l]]=0) or
                           (r[i+irany[1,l],j+irany[2,l]]>k+1)
                                then begin
                                     r[i+irany[1,l],j+irany[2,l]]:=k+1;
                                     mehet:=true;
                                     end;
        k:=k+1;
        until not mehet;
        end;
procedure juliafuss;
        var i,j,k,l:integer;
            mehet:boolean;
        begin
        k:=1;
        repeat
        mehet:=false;
        for i:=1 to n do
           for j:=1 to m do
                if ju[i,j]=k then
                    for l:=1 to 8 do
                        if (ju[i+irany[1,l],j+irany[2,l]]=0) or
                           (ju[i+irany[1,l],j+irany[2,l]]>k+1)
                                then begin
                                     ju[i+irany[1,l],j+irany[2,l]]:=k+1;
                                     mehet:=true;
                                     end;
        k:=k+1;
        until not mehet;
        end;
procedure kiir(min,x,y:integer);
   var g:text;

   begin
   assign(g,'rj.out');
   rewrite(g);
   writeln(g,min,' ',x,' ',y);
   close(g);
   end;
procedure keres;
   var i,j,min,x,y:integer;
   begin
   min:=20001;
   for i:=1 to n do
       for j:=1 to m do
          if (r[i,j]=ju[i,j]) and (r[i,j]<>-1)
             then if r[i,j]<min then begin
                                     x:=i;
                                     y:=j;
                                     min:=r[i,j];
                                     end;
   kiir(min,x,y);
   end;
begin
beolv(n,m);
romeofuss;
juliafuss;
keres;
end.