Лабиринт. Найти самый короткий путь от входа в выходу

uses crt;
 
const
   max_x = 1000000;
   max_y = 1000000;
 
type
   TEleam = Longword;
   TLine = array[1..maxint div sizeof(TEleam)] of TEleam;
   PLine = ^TLine;
   TCol = array[1..maxint div sizeof(TEleam)] of PLine;
   PCol = ^TCol;
   TFile = file of TEleam;
 
var
   d:PCol = NIL;
   a:array[1..5,1..2] of string;
   b:array[1..2] of byte;
   i,j,x,y:Longword;
   l,q,u:byte;
   f:text;
   c:char;
   z,p,ext:boolean;
 
procedure rd(s:string; var x:Longword);
begin
    repeat
        write(s);
        {$I-}
        readln(x);
        {$I+}
    until ioresult=0;
end;
 
procedure rdd(var f:TFile; var x:TEleam; var u:boolean);
begin
    {$I-}
    read(f,x);
    {$I+}
    if ioresult<>0 then u:=false;
end;
 
procedure lv(s1,s2:string; max_x,max_y:Longword; var x,y:Longword);
var
   s:string;
begin
   clrscr;
    str(max_y,s);
    repeat
        rd(s1+' [1;'+s+']: ',y);
    until (1<=y) and (y<=max_y);
   str(max_x,s);
   repeat
        rd(s2+' [1;'+s+']: ',x);
    until (1<=x) and (x<=max_x);
    clrscr;
end;
 
procedure pr(var d:PCol; x,y:Longword; var z,p:boolean);
begin
    for i:=1 to y do freemem(d^[i],x*sizeof(TEleam));
    freemem(d,y*sizeof(PLine));
    z:=false;
    p:=false;
end;
 
function error(var d:PCol; x,y:Longword):boolean;
var
   j:Longword;
begin
   error:=true;
   getmem(d,y*sizeof(PLine));
   if d<>NIL then
   begin
      for j:=1 to y do
      begin
         getmem(d^[j],x*sizeof(TEleam));
         if d^[j]=NIL then
         begin
            error:=false;
            break;
         end;
      end;
        if not(error) then for j:=j-1 downto 1 do freemem(d^[j],x*sizeof(TEleam));
   end else
   begin
        freemem(d,y*sizeof(PLine));
        error:=false;
   end;
end;
 
procedure ent;
begin
   write('Для выхода в меню нажмите Enter');
   readln;
end;
 
procedure c_pro_d(var n,m,x,y:Longword);
begin
    x:=n;
    y:=m;
end;
 
procedure c_pro(c:char; var n,m,y,x:Longword);
begin
    if c in [#72,#80] then
    begin
        if (m<>1) and (c=#72) then dec(m);
        if (m<>y) and (c=#80) then inc(m);
    end;
    if c in [#75,#77] then
    begin
        if (n<>1) and (c=#75) then dec(n);
        if (n<>x) and (c=#77) then inc(n);
    end;
end;
 
procedure print(var d:PCol; n,m,x,y:Longword);
var
   i,j:Longword;
begin
    TextColor(15);
    for j:=1 to y do
    begin
        for i:=1 to x do
        begin
            case d^[j]^[i] of
                0:TextBackGround(3);
                1:TextBackGround(0);
                2:TextBackGround(2);
                4:TextBackGround(4);
            end;
            if (i=n) and (j=m) then write('##') else write('  ');
        end;
        writeln;
    end;
    TextBackGround(7);
    TextColor(0);
end;
 
procedure recurs_1(var d:PCol; var x,y,x2,y2:Longword; var l:longint; x1,y1,k:Longword; var z:boolean); forward;
 
procedure mys_1(var d:PCol; var x,y,x2,y2:Longword; var l:longint; x1,y1,k:Longword; var z:boolean; t1,t2,t3,t4:byte);
var
    a:array[1..4] of byte;
    i:byte;
begin
    a[1]:=t1;
    a[2]:=t2;
    a[3]:=t3;
    a[4]:=t4;
    for i:=1 to 4 do
        case a[i] of
        1:if (y1<>y) and (d^[y1+1]^[x1]=0) then recurs_1(d,x,y,x2,y2,l,x1,y1+1,k+1,z); {вниз}
        2:if (x1<>x) and (d^[y1]^[x1+1]=0) then recurs_1(d,x,y,x2,y2,l,x1+1,y1,k+1,z); {вправо}
        3:if (y1<>1) and (d^[y1-1]^[x1]=0) then recurs_1(d,x,y,x2,y2,l,x1,y1-1,k+1,z); {вверх}
        4:if (x1<>1) and (d^[y1]^[x1-1]=0) then recurs_1(d,x,y,x2,y2,l,x1-1,y1,k+1,z); {влево}
        end;
end;
 
procedure recurs_1(var d:PCol; var x,y,x2,y2:Longword; var l:longint; x1,y1,k:Longword; var z:boolean);
begin
    if (l=-1) or  (k<l) then
    begin
        d^[y1]^[x1]:=2;
        if (x1=x2) and (y1=y2) then
        begin
            l:=k;
            z:=true;
        end else
        begin
            if (x1=x2) or (y1=y2) then
            begin
                if (x1=x2) and (y1>y2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,3,4,2,1);
                if (x1=x2) and (y1<y2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,1,4,2,3);
                if (y1=y2) and (x1>x2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,4,3,1,2);
                if (y1=y2) and (x1<x2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,2,3,1,4);
            end else
            begin
                if (x1>x2) and (y1>y2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,4,3,2,1);
                if (x1>x2) and (y1<y2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,4,1,3,2);
                if (x1<x2) and (y1>y2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,3,2,4,1);
                if (x1<x2) and (y1<y2) then mys_1(d,x,y,x2,y2,l,x1,y1,k,z,1,2,3,4);
            end;
        end;
        d^[y1]^[x1]:=0;
    end;
end;
 
procedure recurs_2(var d:PCol; var x,y,x2,y2:Longword; var l:longint; x1,y1,k:Longword; var z:boolean); forward;
 
procedure mys_2(var d:PCol; var x,y,x2,y2:Longword; var l:longint; x1,y1,k:Longword; var z:boolean; t1,t2,t3,t4:byte);
var
    a:array[1..4] of byte;
    i:byte;
begin
    a[1]:=t1;
    a[2]:=t2;
    a[3]:=t3;
    a[4]:=t4;
    for i:=1 to 4 do
        case a[i] of
        1:if (y1<>y) and (d^[y1+1]^[x1]=0) then recurs_2(d,x,y,x2,y2,l,x1,y1+1,k+1,z); {вниз}
        2:if (x1<>x) and (d^[y1]^[x1+1]=0) then recurs_2(d,x,y,x2,y2,l,x1+1,y1,k+1,z); {вправо}
        3:if (y1<>1) and (d^[y1-1]^[x1]=0) then recurs_2(d,x,y,x2,y2,l,x1,y1-1,k+1,z); {вверх}
        4:if (x1<>1) and (d^[y1]^[x1-1]=0) then recurs_2(d,x,y,x2,y2,l,x1-1,y1,k+1,z); {влево}
        end;
end;
 
procedure recurs_2(var d:PCol; var x,y,x2,y2:Longword; var l:longint; x1,y1,k:Longword; var z:boolean);
begin
    if z and (k<=l) then
    begin
        d^[y1]^[x1]:=2;
        if (x1=x2) and (y1=y2) then z:=false else
        begin
            if (x1=x2) or (y1=y2) then
            begin
                if (x1=x2) and (y1>y2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,3,4,2,1);
                if (x1=x2) and (y1<y2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,1,4,2,3);
                if (y1=y2) and (x1>x2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,4,3,1,2);
                if (y1=y2) and (x1<x2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,2,3,1,4);
            end else
            begin
                if (x1>x2) and (y1>y2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,4,3,2,1);
                if (x1>x2) and (y1<y2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,4,1,3,2);
                if (x1<x2) and (y1>y2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,3,2,4,1);
                if (x1<x2) and (y1<y2) then mys_2(d,x,y,x2,y2,l,x1,y1,k,z,1,2,3,4);
            end;
        end;
        if z then d^[y1]^[x1]:=0;
    end;
end;
 
function proc_pro(var d:PCol; max_x,max_y,x,y,x1,y1,x2,y2:Longword; var p:boolean):boolean;
var
    l:longint = -1;
    q:boolean = true;
begin
    if ((1<=x) and (x<=max_x)) and ((1<=y) and (y<=max_y)) and (d<>NIL) then
   begin
        recurs_1(d,x,y,x2,y2,l,x1,y1,0,p);
        if p then recurs_2(d,x,y,x2,y2,l,x1,y1,0,q);
        proc_pro:=true;
   end else proc_pro:=false;
end;
 
procedure proc_12(var d:PCol; max_x,max_y,x,y:Longword; z:boolean; var p:boolean);
var
    t,n,m,x1,y1,x2,y2:Longword;
    u:boolean = false;
    c:char;
begin
    clrscr;
    if z then
    begin
        for y1:=1 to y do
            for x1:=1 to x do if d^[y1]^[x1]=0 then u:=true;
        if u then
        begin
            t:=0;
            n:=1;
            m:=1;
            repeat
                clrscr;
                if t=0 then writeln('Укажите точку вход:') else writeln('Укажите точку выхода:');
                print(d,n,m,x,y);
                write('Для выбора клетки нажмите Пробел. ');
                c:=readkey;
                if (c=#32) and (d^[m]^[n]<>1) then
                begin
                    if t=0 then c_pro_d(n,m,x1,y1) else c_pro_d(n,m,x2,y2);
                    inc(t);
                    d^[m]^[n]:=4;
                end;
                c_pro(c,n,m,x,y);
            until t=2;
            clrscr;
            if t=0 then writeln('Укажите точку вход:') else writeln('Укажите точку выхода:');
            print(d,n,m,x,y);
            d^[y1]^[x1]:=0;
            d^[y2]^[x2]:=0;
            if proc_pro(d,max_x,max_y,x,y,x1,y1,x2,y2,p) then
            begin
                write('Обработка успешна закончена. ');
               if p then write('Решение есть. ') else write('Решение нет. ');
            end else write('Обработка закончина коректно. ');
        end else write('Для данной таблицы невозможно задать точки входа и выхода. ');
    end else write('Таблица ещё не создана. ');
   ent;
end;
 
procedure proc_13(var d:PCol; x,y:Longword; z,p:boolean);
begin
   clrscr;
   if z and p then
   begin
        writeln('Таблица:');
        print(d,0,0,x,y);
    end else if z then write('Таблица ещё на обработана. ') else write('Таблица ещё не создана. ');
   ent;
end;
 
procedure proc_14(var d:PCol; x,y:Longword; z:boolean);
var
    i,j:Longword;
    f:TFile;
    s:string = '';
begin
   clrscr;
   if z then
   begin
        write('Введите имя файла: ');
        readln(s);
        assign(f,s);
        rewrite(f);
        write(f,x,y);
        for j:=1 to y do
            for i:=1 to x do write(f,d^[j]^[i]);
      write('Таблица записана успешно. ');
      close(f);
   end else write('Таблица ещё не создана. ');
   ent;
end;
 
procedure proc_21(var d:PCol; max_x,max_y:Longword; var x,y:Longword; var z,p:boolean);
var
    n,m:Longword;
    c:char;
begin
    if z then pr(d,x,y,z,p);
    lv('Введите количество строк в интервале','Введите количество столбцов в интервале',max_x,max_y,x,y);
    if error(d,x,y) then
    begin
        for j:=1 to y do
         for i:=1 to x do d^[j]^[i]:=0;
      n:=1;
      m:=1;
      repeat
            clrscr;
            writeln('Заполните таблицу:');
            print(d,n,m,x,y);
            write('Для выбора клетки нажмите Пробел. Для выхода в меню нажмите Enter');
            c:=readkey;
            if c=#32 then if d^[m]^[n]=0 then d^[m]^[n]:=1 else d^[m]^[n]:=0;
            c_pro(c,n,m,x,y);
      until c=#13;
        z:=true;
    end else
    begin
        write('Нехватает памяти. ');
        ent;
    end;
end;
 
procedure proc_22(var d:PCol; max_x,max_y:Longword; var x,y:Longword; var z,p:boolean);
var
   i,j:Longword;
begin
    if z then pr(d,x,y,z,p);
    lv('Введите количество строк в интервале','Введите количество столбцов в интервале',max_x,max_y,x,y);
    if error(d,x,y) then
    begin
        Randomize;
        for j:=1 to y do
         for i:=1 to x do d^[j]^[i]:=Random(1000) mod 2;
      writeln('Таблица заполнена случайными числами:');
      print(d,0,0,x,y);
      z:=true;
    end else write('Нехватает памяти. ');
   ent;
end;
 
procedure proc_23(var d:PCol; max_x,max_y:Longword; var x,y:Longword; var z,p:boolean);
var
    i,j:Longword;
    s:string = '';
    u:boolean = true;
    f:TFile;
begin
    if z then pr(d,x,y,z,p);
    clrscr;
   write('Введите имя файла: ');
   readln(s);
   assign(f,s);
   {$I-}
   reset(f);
   {$I+}
   if  ioresult=0 then
   begin
        rdd(f,x,u);
        rdd(f,y,u);
        if u then
        begin
            if error(d,x,y) then
            begin
                for j:=1 to y do
                    for i:=1 to x do rdd(f,d^[j]^[i],u);
                if u then
                begin
                    clrscr;
                    writeln('Таблица успешно считана:');
                    print(d,0,0,x,y);
                    z:=true;
                end else
                begin
                    pr(d,x,y,z,p);
                    write('Ошибка в файле. ');
                end;
            end else write('Нехватает памяти. ');
        end else write('Ошибка в файле');
   end else write('Такова файла несуществует. ');
   ent;
   {$I-}
   close(f);
   {$I+}
end;
 
begin
   assign(f,'config.txt');
   reset(f);
   readln(f,u);
   for j:=1 to u do
   begin
      readln(f,b[j]);
      for i:=1 to b[j] do readln(f,a[i,j]);
   end;
   x:=0;
   y:=0;
   q:=1;
   l:=1;
   z:=false;
   p:=false;
   ext:=false;
   returnnilifgrowheapfails:=true;
   repeat
      TextBackGround(7);
      clrscr;
      for i:=1 to b[q] do
      begin
         if l=i then
         begin
            TextColor(15);
            TextBackGround(2);
         end else
         begin
            TextColor(0);
            TextBackGround(7);
         end;
         writeln(a[i,q]);
      end;
      TextColor(0);
      TextBackGround(7);
      c:=readkey;
      if c=#13 then
      begin
          case q of
             1:case l of
                  1:q:=2;
                  2:proc_12(d,max_x,max_y,x,y,z,p);
                  3:proc_13(d,x,y,z,p);
                  4:proc_14(d,x,y,z);
                  5:ext:=true;
               end;
             2:case l of
                  1:proc_21(d,max_x,max_y,x,y,z,p);
                  2:proc_22(d,max_x,max_y,x,y,z,p);
                  3:proc_23(d,max_x,max_y,x,y,z,p);
                  4:begin
                       l:=1;
                       q:=1;
                    end;
               end;
          end;
      end;
      if c in [#72,#80] then
      begin
         if (l<>1) and (c=#72) then dec(l);
         if (l<>b[q]) and (c=#80) then inc(l);
      end;
   until ext;
   if z then pr(d,x,y,z,p);
end.