//Tomasz Lubiński (c)2001
//www.algorytm.org
//generowanie grafu o zadanym nasyceniu
//poszukiwanie cyklu Euler'a w podanym grafie

unit graf;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  wsk_kolejki=^kolejka;
  kolejka = record
            element: SmallInt;
            wskaznik: wsk_kolejki;
            end;
  wagi = record
         p   : SmallInt;
         d   : SmallInt;
         waga: SmallInt;
         end;
  TForm1 = class(TForm)
    Button3: TButton;
    Label3: TLabel;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    ListBox1: TListBox;
    CheckBox1: TCheckBox;
    procedure GenerujClick(Sender: TObject);
    procedure A1(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  poczatek, koniec, gora: wsk_kolejki;
  Macierz: Array of Array of SmallInt;
  lk: Array of wagi;
  n, licznik: Integer;
  cykl, spojnosc: Boolean;

implementation

{$R *.DFM}

//generowanie grafu - macierz dolnotrójkątna
procedure TForm1.GenerujClick(Sender: TObject);
var b,i,j,wierzcholek : Integer;
begin
Finalize(Macierz);
n:=StrToInt(edit1.text);
b:=StrToInt(edit2.text);
SetLength(Macierz, n+1);
for i:=0 to n do
 SetLength(Macierz[i], i);    //tworzenie macierz dolnotrójkątna dynamicznej
randomize;
for i:=2 to n do
 for j:=1 to i-1 do
  if random(100)<b then Macierz[i,j]:=random(1000);   //ustawienie stopnia nasycenia
if CheckBox1.Checked=True Then
 begin
  for wierzcholek:=1 to n-1 do        //parzystosc wierzcholkow
   begin
    i:=0;
    for j:=1 to wierzcholek-1 do
     if macierz[wierzcholek, j]>0 then i:=i+1;
    for j:=wierzcholek+1 to n do
     if macierz[j, wierzcholek]>0 then i:=i+1;
    if (i mod 2) <> 0 then
     begin
      i:=Random(n-wierzcholek)+wierzcholek+1;
       if macierz[i, wierzcholek]>0 then macierz[i, wierzcholek]:=0 else
        macierz[i, wierzcholek]:=random(1000);
     end;
 end;
 end;
end;

procedure DoKolejki(var koniec: wsk_kolejki; element:Integer);
var poprzedni: wsk_kolejki;
begin
licznik:=licznik+1;
if poczatek<>nil then
 begin
  poprzedni:=koniec;
  New(koniec);
  poprzedni^.wskaznik:=koniec;
  koniec^.element:=element;
  koniec^.wskaznik:=nil;
 end
else
 begin
  New(koniec);
  koniec^.element:=element;
  koniec^.wskaznik:=nil;
  poczatek:=koniec;
 end;
end;

procedure ZKolejki(var poczatek: wsk_kolejki; var element:Integer);
var nastepny: wsk_kolejki;
begin
if poczatek<>nil then
 begin
  element:=poczatek^.element;
  nastepny:=poczatek^.wskaznik;
  Dispose(poczatek);
  poczatek:=nastepny;
  if poczatek=nil then koniec:=nil;
 end;
end;

procedure W_Szerz;           //przegladanie grafu wszerz
var a, wierzcholek: Integer;
begin
DoKolejki(koniec, 1);
macierz[1,0]:=1;
repeat
ZKolejki(poczatek, wierzcholek);
 for a:=1 to wierzcholek-1 do
  if (macierz[wierzcholek, a]>0) and (macierz[a,0]=0) then
   begin
   DoKolejki(koniec, a);
   macierz[a,0]:=1;
   end;
 for a:=wierzcholek+1 to n do
  if (macierz[a, wierzcholek]>0) and (macierz[a,0]=0) then
   begin
   DoKolejki(koniec, a);
   macierz[a,0]:=1;
   end;
until poczatek=nil;
if licznik<>n then spojnosc:=false else spojnosc:=true;
end;

procedure ZeStosu(var gora: wsk_kolejki; var element: Integer);
var poprzedni: wsk_kolejki;
begin
if gora<>nil then
 begin
  element:=gora^.element;
  poprzedni:=gora^.wskaznik;
  Dispose(gora);
  gora:=poprzedni;
 end;
end;

procedure NaStos(var gora: wsk_kolejki; var element: Integer);
var poprzedni: wsk_kolejki;
begin
 poprzedni:=gora;
 New(gora);
 gora^.element:=element;
 gora^.wskaznik:=poprzedni;
end;

procedure Cykl_Eulera;
var a,wierzcholek,i: Integer;
label tutaj;
begin
W_Szerz;
if spojnosc=false then exit;     //jezeli nie jest spójny to nie ma cyklu
cykl:=false;
for wierzcholek:=1 to n do        //zbadanie parzystosci wierzcholkow
 begin
  i:=0;
  for a:=1 to wierzcholek-1 do
   if macierz[wierzcholek, a]>0 then i:=i+1;
  for a:=wierzcholek+1 to n do
   if macierz[a, wierzcholek]>0 then i:=i+1;
  if (i mod 2) <> 0 then exit;
 end;
cykl:=true;
wierzcholek:=1;
NaStos(gora, wierzcholek);
while gora<>nil do //szukanie cyklu tak dlugo jak jes jakis wierzcholek na stosie
begin
tutaj:
wierzcholek:=gora^.element;
   for a:=1 to wierzcholek-1 do
    if macierz[wierzcholek, a]>0 then
     begin
      macierz[wierzcholek, a]:=-macierz[wierzcholek, a];
      NaStos(gora,a);                    //wrzucanie wierzcholka na stos
      goto tutaj
     end;
   for a:=wierzcholek+1 to n do
    if macierz[a, wierzcholek]>0 then
     begin
      macierz[a, wierzcholek]:=-macierz[a, wierzcholek];
      NaStos(gora,a);                   //wrzucanie wierzcholka na stos
      goto tutaj
     end;
ZeStosu(gora, wierzcholek);   //zdejmowanie ze stosu gdy nie ma gdzie pojsc
Form1.ListBox1.Items.Add(IntToStr(wierzcholek));
end;
end;

procedure TForm1.A1(Sender: TObject);
var i,wierzcholek: Integer;
begin
ListBox1.Items.Clear;
Cykl_Eulera;
if cykl=false then ListBox1.Items.Add('Brak Cyklu') else ListBox1.Items.Add('Cykl:');
if spojnosc=false then ListBox1.Items.Add('Graf nie jest spojny') else ListBox1.Items.Add('Graf jest spojny');
for i:=1 to n do macierz[i,0]:=0;  //wyzerowanie odwiedzin wierzcholka
licznik:=0;
for wierzcholek:=1 to n do         //wyzerowanie odwiedzin krawedzi
 begin
  for i:=1 to wierzcholek-1 do
   if macierz[wierzcholek, i]<0 then macierz[wierzcholek, i]:=-macierz[wierzcholek, i];
  for i:=wierzcholek+1 to n do
   if macierz[i, wierzcholek]<0 then macierz[i, wierzcholek]:=-macierz[i, wierzcholek];
 end;
end;

end.