|
|
Регистрация Восстановить пароль |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
Опции темы | Поиск в этой теме |
08.12.2012, 23:25 | #1 |
Регистрация: 24.09.2012
Сообщений: 4
|
Поиск в ширину
Здравствуйте, нужна помощь в решении задачи на паскале.
Имеются расписания вылетов самолетов в ряде аэропортов. Требуется по начальному и конечному пунктам предложить варианты маршрута с возможными пересадками в порядке возрастания числа пересадок. Для поиска вариантов реализовать алгоритм поиска в ширину. У меня есть программа уже рабочая, осталось только проиллюстрировать, т.е. вывести на экран то как программа ищет нужный путь. приложение к файлу PAS файл GRAF. Содержание файла GRAF: Moskva-Piter. Moskva-Tula. Piter-Saratov. Piter-Penza. и т.д. |
08.12.2012, 23:25 | #2 |
Регистрация: 24.09.2012
Сообщений: 4
|
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('OSHIBKA'); 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 Clrscr; writeln('Матрица смежности: '); writeln; Write(' '); For m:=1 to n-1 do Write(m:2); {номера столбцов матрицы} Writeln; For k:=1 to n-1 do begin Write(k:2); {номера строк матрицы} 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_graf(p:ukaz); begin if p=nil then begin t:=t^.back; if t^.back<>nil then sozd_graf(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_graf(p^.right) else begin t:=p; sozd_graf(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_graf(p^.back^.left) else begin t:=p^.back; sozd_graf(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; {процедура поиска} 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_graf(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. |
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Prolog поиск в ширину | lilian | Помощь студентам | 0 | 20.10.2011 23:52 |
Поиск в ширину и глубину | Дядя Тёма | Фриланс | 0 | 21.05.2011 10:42 |
поиск в ширину | ooooch | Помощь студентам | 1 | 29.11.2009 11:26 |
поиск в ширину на с++ | Pavel.d | Помощь студентам | 1 | 19.04.2009 12:08 |