Informatika gyűjtemény

Egy szinttel feljebb ketutoo.pas

2004050607080910

<<  16. óra  >>

<<  Két út  >>

NézetNyomtat

ketutoo.pas (Vissza)
Az alábbi letöltési lehetőségek közül választhatsz: (segítség)
Karakterkódolás:
Sortörés:
Típus: text/plain
Tartalmaz szöveget
Karakterkódolás: utf-8
Méret: 6 KB
Program ketut;
uses crt;
Const bef = 'ketut.be7';
      feher = 1;
      piros = 2;
      kek   = 3;
      sarga = 4;

Type csucs = Record
                   apa : Byte;
                   volt: Byte;
             End;

      Tsor = Object
                  t   : Array[1..200] of Byte;
                  cs  : Array[1..200] of csucs;
                  db  : Byte;
                  e,v : Byte;
                  max  : Byte;
                  Procedure Init(n: byte);
                  Procedure Ba(b:byte);
                  Function Bol:byte;
                  Function Volt(i : byte):boolean;
                  Procedure Apa(i,k: byte);
             End;

      Tut = Object
                  ut : array[1..100] of byte;
                  db : byte;
                  Procedure Init;
                  Procedure Be(c:byte);
                  Procedure Kiir;
                  Function ekeres(c:byte):byte;
                  Function ukeres(c:byte):byte;
                  Procedure Epit(num:byte);
             End;


Var el    : array[1..200,1..200] of byte; {szomszédsági mátrix}
    n     : byte; {csúcsok száma az eredeti gráfban -> j: 1..2*n}
    c1,c2 : byte; {célpontok}
    u1,u2 : Tut;  {a megtalált utak}
    sor   : Tsor; {a szélességi kereséshez használt sor}

{-------------------------------------------------------------------------}
{Sor metódusok                                                            }
{-------------------------------------------------------------------------}

    procedure Tsor.init(n : byte); 
    var i : byte;
    begin
     max := n;
     for i := 1 to 2*max do
     begin
          t[i] := 0;
          cs[i].apa := 0;
          cs[i].volt := 0;
     end;
     e := 1; v := 1; db := 0;
    end; {Tsor.Init}

    procedure Tsor.ba(b : byte);
    begin
         t[e] := b;
         Inc(db);
         Inc(e);
         if e > 2*max then e := 1;
         cs[b].volt := 1;
    end; {Tsor.ba}

    function Tsor.bol:byte;
    begin
         if db = 0
            then bol := 0
            else begin
                 bol := t[v];
                 Dec(db);
                 Inc(v);
                 if v > 2*max then v := 1;
            end;
    End; {Tsor.bol}

    Function Tsor.volt(i:byte):boolean;
    Begin
         volt := cs[i].volt=1;
    End; {Tsor.bol}

    Procedure Tsor.Apa(i,k : byte);
    Begin
         cs[i].apa := k;
    End; {Tsor.Apa}

{-------------------------------------------------------------------------}
{Sor metódusok vége                                                       }
{-------------------------------------------------------------------------}

{-------------------------------------------------------------------------}
{Ut metódusok                                                             }
{-------------------------------------------------------------------------}

    Procedure Tut.Init;
    var i : byte;
    Begin
         db := 0;
         for i := 1 to 100 do ut[i] := 0;
    End; {Tut.Init}

    Procedure Tut.Be(c:byte);
    Begin
         Inc(db);
         ut[db] := c;
    End; {Tut.Be}

    Procedure Tut.Kiir;
    var i : byte;
    Begin
         write(ut[1]);
         for i := 2 to db do write(' ',ut[i]);
         writeln;
    End; {Tut.Kiir}

    Function Tut.ekeres(c:byte):byte;
    Var i : byte;
    Begin
         i := 2;
         while el[c,i] <> sarga do inc(i);
         ekeres := i;
    End; {Tut.ekeres}


    Function Tut.ukeres(c:byte):byte;
    Var i : byte;
    Begin
         i := 2*n;
         while el[c,i] <> sarga do dec(i);
         ukeres := i;
    End; {Tut.ukeres}

    Procedure Tut.Epit(num : byte);
    var j : byte;
    Begin
         Self.Be(1);
         if num = 1 then j := ekeres(1) else j := ukeres(1);
         while j <> 2*n do
         begin
              if (j mod 2) = 1 then self.Be((j+1)div 2);
              j := ekeres(j);
          end;
    End; {Tut.Epit}
{-------------------------------------------------------------------------}
{Ut  metódusok vége                                                       }
{-------------------------------------------------------------------------}
Procedure Beolvas;
var be : Text;
    m  : integer;
    i,j: integer;
    x,y: byte;
Begin
     for i:=1 to 200 do
     for j:=1 to 200 do el[i,j] := 0;

     assign(be,bef);
     reset(be);
     readln(be,n,c1,c2,m);
     for i := 2 to n do el[2*i-2,2*i-1] := feher; {be -> ki}

     for i := 1 to m do {eredeti élek}
     begin
          readln(be,x,y);
          el[2*x-1,2*y-2] := feher;
     end;
     close(be);

     el[2*c1-1,2*n] := feher; {extra nyelő}
     el[2*c2-1,2*n] := feher;

End; {Beolvas}

Function vanel(x,y:byte):boolean;
Begin
     vanel := (el[x,y]=feher) OR (el[y,x]=piros);
End; {vanel}

procedure bejar;
var i,k : byte;
Begin
     sor.init(n);
     sor.ba(1);
     k := sor.bol;
     while (k > 0) and (not sor.Volt(2*n)) do
     begin
          for i := 1 to 2*n do
          begin
               if vanel(k,i) AND (not sor.volt(i))
               then begin
                    sor.ba(i);
                    sor.apa(i,k);
               end;
          end;
          k := sor.bol;
     end;
end; {bejar}

function utKeres(szin:byte):boolean;
var i,j : byte;
Begin
     bejar;
     if not sor.volt(2*n)
     then
         utKeres := false
     else begin
         utKeres := true;
         j := 2*n;
         i := sor.cs[j].apa;
         while i > 0 do
         begin
              el[i,j] := szin;
              j := i;
              i := sor.cs[j].apa;
         end;
     end;
End; {utKeres}

Procedure Ketto;
var i,j : byte;
Begin
     for i := 1 to 2*n-1 do
     for j := i+1 to 2*n do
         if ((el[i,j] = piros) and (el[j,i]<>kek))
            or (el[i,j] = kek)
            then el[i,j] := sarga;
     u1.epit(1);
     u2.epit(2);
End; {Ketto}

procedure kiir;
begin
     writeln(u1.db,' ',u2.db);
     u1.kiir;
     u2.kiir;
end;

Begin {main}
      clrscr;
      Beolvas;
      if utKeres(piros) and utKeres(kek)
         then begin
                   ketto;
                   kiir;
              end
         else writeln('0 0');

      readln;
End. {of program}
(Vissza)