В чём можно запустить эту программу? - Pascal

Формулировка задачи:

В чём это можно запустить
{uses crt;}
const
 n=100;
type
 used=array[1..n] of boolean;
var
 t:byte;
 graf:array[1..n,1..n] of byte;
 cherga:array[1..n] of byte;
 d1,d2,u:used;
 i,j,k,g,h:integer;
 dvodolnyj:boolean;
 
 
procedure rec(x:byte; first:boolean);
begin
 if dvodolnyj then
   begin
     u[x]:=true;
     for i:=1 to n do
       if graf[x,i]=1 then
         begin
           if not(u[i])  then
             begin
               if first then d2[i]:=true
               else d1[i]:=true;
               rec(i,not first);
             end
           else if (d1[x] AND d1[i]) OR (d2[x] AND d2[i]) then
      begin
        writeln('Graf NE dvodolnyj!');
        dvodolnyj:=false;
        readln;
        exit;
      end;
  end;
   end;
end;
 
 
procedure vGlyb;
begin
 dvodolnyj:=true;
 d1[1]:=true;
 rec(1,true);
 if dvodolnyj then
 begin
   writeln('Graf dvodolnyj');
   for i:=1 to n do
     if d1[i] then write(i:2);
   writeln;
   for i:=1 to n do
     if d2[i] then write(i:2);
   readln;
 end;
end;
 
procedure zero_Vglyb;
 begin
 t:=1;
 for i:=1 to n do
  begin
    u[i]:=false;
    d1[i]:=false;
    d2[i]:=false;
  end;
 for i:=1 to n do
   for j:=1 to n do graf[i,j]:=0;
end;
 
procedure push(x:byte);
var
 i:integer;
begin
 cherga[t]:=x;
 inc(t);
end;
 
function pop:byte;
var
 i,x:byte;
begin
 x:=cherga[1];
 for i:=2 to n do
  cherga[i-1]:=cherga[i];
 dec(t);
 pop:=x;
end;
 
function emptyqq:boolean;
begin
 if t=1 then emptyqq:=true
        else emptyqq:=false;
end;
 
procedure vShyrynu;
var
 x,i,j:byte;
begin
 dvodolnyj:=true;
 push(1);
 d1[1]:=true;
 u[1]:=true;
 while not emptyqq do
 begin
  x:=pop;
  for i:=1 to n do
   if graf[x,i]=1 then
   begin
    if not(u[i]) then
      begin
        if d1[x] then d2[i]:=true
        else d1[i]:=true;
        u[i]:=true;
        push(i);
      end
    else if (d1[x] AND d1[i]) OR (d2[x] AND d2[i]) then
      begin
        writeln('Graf NE dvodolnyj!');
        readln;
        exit;
      end;
   end;
 end;
 writeln('Graf dvodolnyj');
 for i:=1 to n do
  if d1[i] then write(i:2);
 writeln;
 for i:=1 to n do
  if d2[i] then write(i:2);
 readln;
end;
 
procedure zero_Vshur;
var
 i,j:byte;
begin
 t:=1;
 for i:=1 to n do
  begin
    u[i]:=false;
    d1[i]:=false;
    d2[i]:=false;
  end;
 for i:=1 to n do
  begin
   cherga[i]:=0;
   for j:=1 to n do graf[i,j]:=0;
  end;
end;
 
procedure test;
var k:integer;
begin
 Write('Vvedit kilkist reber: '); readln(k);
for i:=1 to k do
begin
Write('Vvedit cherez probil vershunu ',i,' rebra: '); Readln(g,h);
 graf[g,h]:=1;
 graf[h,g]:=1;
end;
end;
 
var key:char;
 
BEGIN
while key<>'3' do
begin
{ clrscr;}
writeln('1. V SHURUNY');
writeln('2. V GLYBUNY');
writeln('3. EXIT');
write('>>>');
read(key);
case key of
 '1':begin
    { clrscr;}
     zero_Vglyb;
     test;
     vGlyb;
     end;
'2':begin
     {clrscr;}
     zero_Vshur;
     test;
     vShyrynu;
     end;
end;
end;
 
END.

Код к задаче: «В чём можно запустить эту программу? - Pascal»

textual
{uses crt;}
const
  n = 100;
 
type
  used = array[1..n] of boolean;
 
var
  t: byte;
  graf: array[1..n, 1..n] of byte;
  cherga: array[1..n] of byte;
  d1, d2, u: used;
  i, j, k, g, h: integer;
  dvodolnyj: boolean;
 
 
procedure rec(x: byte; first: boolean);
var
  i: integer;
begin
  if dvodolnyj then
  begin
    u[x] := true;
    for i := 1 to n do
      if graf[x, i] = 1 then
      begin
        if not (u[i])  then
        begin
          if first then d2[i] := true
          else d1[i] := true;
          rec(i, not first);
        end
        else if (d1[x] AND d1[i]) OR (d2[x] AND d2[i]) then
        begin
          writeln('Graf NE dvodolnyj!');
          dvodolnyj := false;
          readln;
          exit;
        end;
      end;
  end;
end;
 
 
procedure vGlyb;
var
  i: integer;
begin
  dvodolnyj := true;
  d1[1] := true;
  rec(1, true);
  if dvodolnyj then
  begin
    writeln('Graf dvodolnyj');
    for i := 1 to n do
      if d1[i] then write(i:2);
    writeln;
    for i := 1 to n do
      if d2[i] then write(i:2);
    readln;
  end;
end;
 
procedure zero_Vglyb;
var
  i, j: integer;
begin
  t := 1;
  for i := 1 to n do
  begin
    u[i] := false;
    d1[i] := false;
    d2[i] := false;
  end;
  for i := 1 to n do
    for j := 1 to n do graf[i, j] := 0;
end;
 
procedure push(x: byte);
var
  i: integer;
begin
  cherga[t] := x;
  inc(t);
end;
 
function pop: byte;
var
  i, x: byte;
begin
  x := cherga[1];
  for i := 2 to n do
    cherga[i - 1] := cherga[i];
  dec(t);
  pop := x;
end;
 
function emptyqq: boolean;
begin
  if t = 1 then emptyqq := true
  else emptyqq := false;
end;
 
procedure vShyrynu;
var
  x, i, j: byte;
begin
  dvodolnyj := true;
  push(1);
  d1[1] := true;
  u[1] := true;
  while not emptyqq do
  begin
    x := pop;
    for i := 1 to n do
      if graf[x, i] = 1 then
      begin
        if not (u[i]) then
        begin
          if d1[x] then d2[i] := true
          else d1[i] := true;
          u[i] := true;
          push(i);
        end
        else if (d1[x] AND d1[i]) OR (d2[x] AND d2[i]) then
        begin
          writeln('Graf NE dvodolnyj!');
          readln;
          exit;
        end;
      end;
  end;
  writeln('Graf dvodolnyj');
  for i := 1 to n do
    if d1[i] then write(i:2);
  writeln;
  for i := 1 to n do
    if d2[i] then write(i:2);
  readln;
end;
 
procedure zero_Vshur;
var
  i, j: byte;
begin
  t := 1;
  for i := 1 to n do
  begin
    u[i] := false;
    d1[i] := false;
    d2[i] := false;
  end;
  for i := 1 to n do
  begin
    cherga[i] := 0;
    for j := 1 to n do graf[i, j] := 0;
  end;
end;
 
procedure test;
var
  k, i: integer;
begin
  Write('Vvedit kilkist reber: ');readln(k);
  for i := 1 to k do
  begin
    Write('Vvedit cherez probil vershunu ', i, ' rebra: ');Readln(g, h);
    graf[g, h] := 1;
    graf[h, g] := 1;
  end;
end;
 
var
  key: char;
 
begin
  while key <> '3' do
  begin
    { clrscr;}
    writeln('1. V SHURUNY');
    writeln('2. V GLYBUNY');
    writeln('3. EXIT');
    write('>>>');
    read(key);
    case key of
      '1':
        begin
          { clrscr;}
          zero_Vglyb;
          test;
          vGlyb;
        end;
      '2':
        begin
          {clrscr;}
          zero_Vshur;
          test;
          vShyrynu;
        end;
    end;
  end;
  
end.

Нужна аналогичная работа?

Оформи быстрый заказ и узнай стоимость

10   голосов, оценка 4.100 из 5


СОХРАНИТЬ ССЫЛКУ