Версия для печати темы

unit MyLabirint;

interface

  uses SysUtils, MyConsoleIO;

  const MaxN=20;
        MaxM=20;

  var WayExists: boolean;

  type Maze=array [0..MaxN+1, 0..MaxM+1] of byte;
       Point=record
               x,y:byte;
             end;
       Way=array [1..MaxN*MaxM] of Point;

  procedure InputLabirint(var A: Maze;N,M :integer); overload;
  procedure InputLabirint(s: string;var A: Maze;N,M :integer); overload;
  procedure PrintLabirint(const A: Maze;N,M :integer);
  procedure PrintWay(const w: Way;c: integer);
  procedure Search(A: Maze;F: Point;x,y: byte;w: Way;c: integer;var optw: Way;var optc: integer);
  procedure AddBarier(N,M :integer;var A: Maze);
  function LineCount(s: string):integer;
  function ColumnCount(s: string):integer;

implementation

  // ввод лабиринта с клавиатуры

  procedure InputLabirint(var A: Maze;N,M :integer); overload;
  var i,j: integer;
  begin
    Writeln;
    for i:=1 to N do
    begin
      for j:=1 to M do
      begin
        Read(A[i,j]);
      end;
      Writeln;
    end;
    WayExists:=false;
  end;

  // ввод лабиринта из текстового файла

  procedure InputLabirint(s: string;var A: Maze;N,M :integer); overload;
  var i,j: integer;
      f: text;
  begin
    assign(f,s);
    reset(f);
    for i:=1 to N do
    begin
      for j:=1 to M do
          Read(f,A[i,j]);
      writeln;
    end;
    closefile(f);
    WayExists:=false;
  end;

  // вывод лабиринта

  procedure PrintLabirint(const A: Maze;N,M :integer);
  var i,j: integer;
  begin
    Writeln;
    for i:=0 to N+1 do
    begin
      for j:=0 to M+1 do
        Write(A[i,j]:4);
      Writeln;
    end;
    Writeln;
  end;

  // вывод пути

  procedure PrintWay(const w: Way;c: integer);
  var i: integer;
  begin
    Writeln;
    for i:=1 to c-1 do
      Write(w[i].x,', ',w[i].y,' -> ');
    Write(w[c].x,', ',w[c].y);
    Writeln;
  end;

  // поиск решения

  procedure Search(A: Maze;F: Point;x,y: byte;w: Way;c: integer;var optw: Way;var optc: integer);
  begin
    c:=c+1;
    w[c].x:=x;
    w[c].y:=y;
    A[x,y]:=2;                                    //запись варианта
    if (x=F.x) and (y=F.y) then                   // путь найден
    begin
      WayExists:=true;
      Writeln(StringWinToDos('Ïóòü åñòü!!!'));
      PrintWay(w,c);
      if c<optc then
      begin
        optc:=c;
        optw:=w;
      end;
      Readln;
      // Halt;    //для нахождения одного решения
    end
    else
    begin
      if A[x,y+1]=0 then Search(A,F,x,y+1,w,c,optw,optc);           // if  вариант подходит then
      if A[x,y-1]=0 then Search(A,F,x,y-1,w,c,optw,optc);           //    рекурсивный вызов
      if A[x-1,y]=0 then Search(A,F,x-1,y,w,c,optw,optc);
      if A[x+1,y]=0 then Search(A,F,x+1,y,w,c,optw,optc);
    end;
    A[x,y]:=0;                                    // стирание варианта
    c:=c-1;
  end;

  // добавление барьера

  procedure AddBarier(N,M :integer;var A: Maze);
  var i,j: integer;
  begin
    for i:=0 to N+1 do
      for j:=0 to M+1 do
       if (i=0)or(i=N+1)or(j=0)or(j=M+1) then A[i,j]:=1;
  end;

  // определение количества строк в текстовом файле (=высота лабиринта)

  function LineCount(s: string):integer;
  var f: text;
  begin
    assignfile(f,s);
    Result:=0;
    reset(f);
    while not eof(f) do
    begin
      readln(f);
      inc(Result);
    end;
    closefile(f);
  end;

  //определение количества столбцов из "0" и "1" в текстовом файле (=ширина лабиринта)

  function ColumnCount(s: string):integer;
  var f: text;
  begin
    assignfile(f,s);
    Result:=0;
    reset(f);
    while not seekeoln(f) do
    begin
      readln(f);
      inc(Result);
    end;
    closefile(f);
  end;

end.