Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 20.12.2012, 22:20   #1
olegass
 
Регистрация: 24.10.2012
Сообщений: 5
Стрелка PASCAl в DELPHI

Кто может помочь переделать в дельфи код.
Код:
program Graf;
uses crt;
type mat=array[1..10,1..10] of integer; { матрица смежности }
     ukaz=^usel;
     usel=record
            key:integer;
            left,right,back:ukaz;
          end;
var
  top,t,p,q,ps:ukaz;                        {для дерева}
  matr : mat;
  gr,gp:array [1..100] of integer;
  f:text;
  l,r,w:boolean;
  fail,s:string;
  word,m1,m2:array [1..20] of string;
  ch:char;
  i,j,a,b,m,n,k,strok,stolb,z,kolway:integer;
procedure Chtenie;     { чтение из файла }
  begin
    assign(f,fail);
    reset(f);
    if IoResult<>0 then writeln('Oshbka');
    while not Eof(f) do
      begin
        readln(f,s);
        m:=1; if s='' then exit;
        while (s[m]<>'-') and (s[m]<>' ') do begin
                             m1[i]:=m1[i]+s[m];
                             m:=m+1;
                           end;
        if s[m]='-' then begin i:=i+1; m:=m+1; end;
        while (s[m]<>'.') and (s[m]<>' ')  do begin
                             m2[j]:=m2[j]+s[m];
                             m:=m+1;
                           end;
        if s[m]='.' then begin m:=1; j:=j+1; end;
      end;
    close(f);
  end;
Procedure zadanie;       { задание матрицы смежности }
  begin
    For k:=1 to n-1 do
      For m:=1 to n-1 do
        begin
          matr[k,m]:=0;
          matr[k,m]:=0
        end;
    for m:=1 to i-1 do begin
      for k:=1 to n-1 do
        begin
          if m1[m]=word[k] then strok:=k;
          if m2[m]=word[k] then stolb:=k;
        end;
      matr[strok,stolb]:=1;
    end;
  end;
  Procedure Wiwod(matr: mat);
    Begin
      TextBackGround(Cyan);
      Clrscr;
      TextColor(LightGreen);
      writeln('Матрица смежности: ');
      writeln;
      Write('  ');
      For m:=1 to n-1 do
        Write(m:2);               { номера столбцов матрицы }
      Writeln;
      For k:=1 to n-1 do
        begin
          TextColor(LightGreen);
          Write(k:2);             { номера строк матрицы }
          TextColor(White);
          For m:=1 to n-1 do
            Write(matr[k,m]:2);
          Writeln
        end;
      writeln;
      for i:=1 to n-1 do writeln(i,'-',word[i]);
    End;
function proverka(j:integer):boolean;
  begin
    if (j<>b) and (j<>268) then begin
    proverka:=true; r:=true;
    for i:=1 to z do
      if j=gp[i] then m:=m+1;
    if m>=10 then begin proverka:=false; r:=false; end;
    if r=true then begin gp[z]:=j; z:=z+1; end;
  end; end;
procedure sozd_tree(p:ukaz);
  begin
    if p=nil then
      begin
        t:=t^.back;
        if t^.back<>nil then sozd_tree(t^.right);
        if t^.back=nil then l:=false;
      end;
    if ((p<>top) and ((p^.key=a) or (p^.key=b))) or (proverka(p^.key)=false) then
      if p^.right<>nil then sozd_tree(p^.right) else
      begin
        t:=p;
        sozd_tree(p^.back^.right);
      end;
    if l=true then begin
    k:=0; j:=p^.key; ps:=p;
    for i:=1 to n do
      if matr[j,i]=1 then
        begin
          new(q);
          q^.key:=i;
          q^.left:=nil;
          q^.right:=nil;
          q^.back:=ps;
          if k=1 then begin p^.right:=q; p:=q; end
                 else begin p^.left:=q; p:=q; k:=1; end;
        end;
    if k=1 then sozd_tree(p^.back^.left)
           else begin t:=p^.back; sozd_tree(t^.right); end;
  end; end;
procedure put(t:ukaz);
  begin
    i:=1;
    while t<>nil do
      begin
        gr[i]:=t^.key;
        i:=i+1;
        t:=t^.back;
      end;
    for j:=i-1 downto 1 do write(word[gr[j]],'    ');
  end;
procedure obxod(p:ukaz);
  begin
    if p<>nil then begin
      if p^.key=b then begin kolway:=kolway+1; write('Найден путь: '); put(p); writeln; end;
      obxod(p^.right);
      obxod(p^.left);
    end;
  end;
olegass вне форума Ответить с цитированием
Старый 20.12.2012, 22:21   #2
olegass
 
Регистрация: 24.10.2012
Сообщений: 5
По умолчанию Продолжение кода

Код:
{==========процедура поиска=================}
procedure poisk;
  begin
    top:=nil;
    new(t);
    t^.key:=a;
    top:=t;
    top^.back:=nil;
    top^.left:=nil;
    top^.right:=nil;
    t:=nil;
    l:=true; z:=1; m:=0; gp[1]:=0;
    sozd_tree(top);
    obxod(top^.left);
  end;
begin
  clrscr;
  write('введите полный путь к файлу: ');
  readln(fail);
  i:=1;j:=1;
  chtenie;
{====Выделение отдельных городов в массив====}
    word[1]:=m1[1];
    n:=1;
    for m:=2 to i-1 do begin
      l:=true;
      for k:=1 to n do
        if word[k]=m1[m] then l:=false;
        if l=true then begin n:=n+1; word[n]:=m1[m]; end;
    end;
    for m:=1 to j do begin
      l:=true;
      for k:=1 to n do
        if word[k]=m2[m] then l:=false;
      if l=true then begin n:=n+1; word[n]:=m2[m]; end;
    end;
{============================================}
  zadanie;
  wiwod(matr);
  w:=true;
   While w do
     begin
       Writeln;
       Write('Введите пункт отправления:  ');
       Readln(a);
       Write('Введите пункт прибытия:  ');
       Readln(b);
       Writeln;
       z:=1; kolway:=0;
       poisk;
       if kolway=0 then writeln('Нет путей');
       Write('Повторить поиск[y/n] ? ');
       Readln(ch);
       if ch='n' then w:=false   { для выхода из цикла }
     end;
end.
olegass вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Из Pascal в Delphi nulyjarden Помощь студентам 0 03.12.2011 20:13
О Pascal/Delphi DM_bite Свободное общение 1 12.09.2008 17:18
из Delphi в Pascal sanek0322 Фриланс 2 17.12.2007 21:33
Из Pascal в Delphi Nivil Помощь студентам 9 08.12.2007 18:58
С Pascal на Delphi =*=|/|MM0PT@/\=*= Паскаль, Turbo Pascal, PascalABC.NET 12 06.09.2007 17:53