{*** Data: 25/set/09 ***}
{-- Verifica se grafo e' aciclico e Atribuig usando 4 bytes por entrada de g--}
program RotulaGrafoAciclico;
const 
  MAXNUMVERTICES = 100000; {--No. maximo de vertices--}
  MAXNUMARESTAS  = 100000; {--No. maximo de arestas--}
  MAXR           = 5;
  MAXTAMPROX     = MAXR*MAXNUMARESTAS;
  MAXTAM         = 1000;   {--Usado Fila--}
  MAXTAMCHAVE    = 6;      {--No. maximo de caracteres da chave--}
  MAXNUMCHAVES   = 100000; {--No. maximo de chaves lidas--}
  INDEFINIDO     = -1;
type
  {-- Tipos usados em GrafoListaInc do Programa 7.25 --}
  TipoValorVertice    = -1..MAXNUMVERTICES;
  TipoValorAresta     = 0..MAXNUMARESTAS;
  Tipor               = 0..MAXR;
  TipoMaxTamProx      = -1..MAXTAMPROX;
  TipoPesoAresta      = integer;
  TipoArranjoVertices = array[Tipor] of TipoValorVertice;
  TipoAresta          = record
                        Vertices: TipoArranjoVertices;
                        Peso    : TipoPesoAresta;
                        end;
  TipoArranjoArestas  = array[TipoValorAresta] of TipoAresta;
  TipoGrafo = 
    record
      Arestas       : TipoArranjoArestas;
      Prim          : array[TipoValorVertice] of TipoMaxTamProx;
      Prox          : array[TipoMaxTamProx] of TipoMaxTamProx;
      ProxDisponivel: TipoMaxTamProx;
      NumVertices   : TipoValorVertice;
      NumArestas    : TipoValorAresta;
      r             : Tipor;
    end;
  TipoApontador = integer;
  { -- Tipos usados em Fila do Programa 3.17 --}
  TipoItem  = record
                Chave: TipoValorVertice;
                { outros componentes }
              end;
  TipoFila  = record
                Item  : array [1..MaxTam] of TipoItem;
                Frente: TipoApontador;
                Tras  : TipoApontador;
              end;
  TipoPesos      = array [1..MAXTAMCHAVE] of integer;
  TipoTodosPesos = array [Tipor] of Tipopesos;
  Tipog          = array[0..MAXNUMVERTICES] of integer;
  TipoChave      = packed array[1..MAXTAMCHAVE] of char;
  TipoConjChaves = array[0..MAXNUMCHAVES] of TipoChave;
  TipoIndice     = TipoValorVertice;
var
  M                   : TipoValorVertice;
  N                   : TipoValorAresta;
  r                   : Tipor;
  Grafo               : TipoGrafo;
  L                   : TipoArranjoArestas;
  GAciclico           : boolean;
  g                   : Tipog; 
  Pesos               : TipoTodosPesos; 
  i, j, NGrafosGerados: integer; 
  ConjChaves          : TipoConjChaves; 
  ArqEntrada          : text;
  ArqSaida            : text;
  NomeArq             : string [100];

{-- Entram aqui os operadores do Programa 3.18 --}
procedure FFVazia (var Fila: TipoFila);
begin
  Fila.Frente := 1;
  Fila.Tras := Fila.Frente;
end; { FFVazia }

function Vazia (Fila: TipoFila): boolean;
begin
  Vazia := Fila.Frente = Fila.Tras;
end; { Vazia }

procedure Enfileira (x: TipoItem; var Fila: TipoFila);
begin
  if Fila.Tras mod MAXTAM + 1 = Fila.Frente
  then writeln ('Erro: fila esta  cheia')
  else begin
       Fila.Item[Fila.Tras] := x;
       Fila.Tras := Fila.Tras mod MAXTAM + 1;
       end;
end; { Enfileira }

procedure Desenfileira (var Fila: TipoFila; var Item: TipoItem);
begin
  if Vazia (Fila)
  then writeln ('Erro: fila esta vazia')
  else begin
       Item := Fila.Item[Fila.Frente];
       Fila.Frente := Fila.Frente mod MAXTAM + 1;
       end;
end; { Desenfileira }

{-- Entram aqui os operadores do Programa 7.26 --}
function ArestasIguais (var V1       : TipoArranjoVertices;
                       var NumAresta : TipoValorAresta;
                       var Grafo     : TipoGrafo): boolean;
var i, j: Tipor;  Aux: boolean;
begin
  Aux := true;  i := 0;
  while (i < Grafo.r) and Aux do 
    begin
    j := 0;
    while (V1[i] <> Grafo.Arestas[NumAresta].Vertices[j]) and 
      (j < Grafo.r) do j := j + 1; 
    if j = Grafo.r then Aux := false; 
    i := i + 1;
    end;
  ArestasIguais := Aux;
end;

procedure FGVazio (var Grafo: TipoGrafo);
var i: integer;
begin
  Grafo.ProxDisponivel := 0;
  for i := 0 to Grafo.NumVertices - 1 do Grafo.Prim[i] := INDEFINIDO;
end;

procedure InsereAresta (var Aresta: TipoAresta;
                        var Grafo : TipoGrafo);
var i, Ind: integer;
begin
  if Grafo.ProxDisponivel = MAXTAMPROX + 1
  then writeln ('Nao ha espaco disponivel para a aresta')
  else begin
       Grafo.Arestas[Grafo.ProxDisponivel] := Aresta;
       for i := 0 to Grafo.r - 1 do
         begin
         Ind := Grafo.ProxDisponivel + i * Grafo.NumArestas;
         Grafo.Prox[Ind] := 
	   Grafo.Prim[Grafo.Arestas[Grafo.ProxDisponivel].Vertices[i]];
         Grafo.Prim[Grafo.Arestas[Grafo.ProxDisponivel].Vertices[i]] := Ind;
         end;
       end;
       Grafo.ProxDisponivel := Grafo.ProxDisponivel + 1;
end;

function ExisteAresta (var Aresta: TipoAresta;
                       var Grafo : TipoGrafo): boolean;
var v: Tipor;  A1: TipoValorAresta;  Aux: integer;  
    EncontrouAresta: boolean;
begin
  EncontrouAresta := false;
  for v := 0 to Grafo.r - 1 do
    begin
    Aux := Grafo.Prim[Aresta.Vertices[v]];
    while (Aux <> -1) and not EncontrouAresta do
      begin
      A1 := Aux mod Grafo.NumArestas;
      if ArestasIguais (Aresta.Vertices, A1, Grafo) 
      then EncontrouAresta := true;
      Aux := Grafo.Prox[Aux];
      end;
    end;
  ExisteAresta := EncontrouAresta;
end; { ExisteAresta }

function RetiraAresta (var Aresta: TipoAresta;
                       var Grafo : TipoGrafo): TipoAresta;
var Aux, Prev, i: integer;  A1: TipoValorAresta;  v: Tipor;
begin
  for v := 0 to Grafo.r - 1 do
    begin
    Prev := INDEFINIDO;
    Aux := Grafo.Prim[Aresta.Vertices[v]];
    A1 := Aux mod Grafo.NumArestas;
    while (Aux >= 0) and 
      not ArestasIguais (Aresta.Vertices, A1, Grafo) do
      begin
      Prev := Aux;  Aux := Grafo.Prox[Aux];
      A1 := Aux mod Grafo.NumArestas;
      end;
    if Aux >= 0 
    then begin  { Achou }
         if Prev = INDEFINIDO 
         then Grafo.Prim[Aresta.vertices[v]] := Grafo.Prox[Aux]
         else Grafo.Prox[Prev] := Grafo.Prox[Aux];
         end;
  { else writeln ('Nao existe aresta ou foi retirada antes'); }
  end;
  RetiraAresta := Grafo.Arestas[A1];
  for i := 0 to Grafo.r-1 do Grafo.Arestas[A1].Vertices[i]:=INDEFINIDO;
  Grafo.Arestas[A1].Peso := INDEFINIDO;
end; { RetiraAresta }

procedure ImprimeGrafo (var Grafo: TipoGrafo);
var i, j: integer; 
begin
  writeln (' Arestas: Num Aresta, Vertices, Peso ');
  for i := 0 to Grafo.NumArestas - 1 do
    begin
    write (i:2);
    for j := 0 to Grafo.r - 1 do write (Grafo.Arestas[i].Vertices[j]:3);
    writeln (Grafo.Arestas[i].Peso:3);
    end;
  writeln ('Lista arestas incidentes a cada vertice: ');
  for i := 0 to Grafo.NumVertices - 1 do
    begin 
    write (i:2);  j := Grafo.Prim[i];
    while j <> INDEFINIDO do
      begin
      write (j mod Grafo.NumArestas:3);  j := Grafo.Prox[j];
      end;
    writeln;
    end;
end;

function VerticeGrauUm (var V: TipoValorVertice;
                        var Grafo: TipoGrafo): Boolean;
begin
  VerticeGrauUm := (Grafo.Prim[V] >= 0) and 
    (Grafo.Prox[Grafo.Prim[V]] = INDEFINIDO); 
end;

procedure GrafoAciclico (var Grafo: TipoGrafo;
                         var L: TipoArranjoArestas;
                         var GAciclico: boolean);
var j: TipoValorVertice; A1: TipoValorAresta;  
    x: TipoItem;  Fila: TipoFila; 
    NArestas: TipoValorAresta;
    Aresta: TipoAresta;
begin
  NArestas := Grafo.NumArestas; 
  FFVazia (Fila);  j := 0;
  while j < Grafo.NumVertices do
    begin
    if VerticeGrauUm (j, Grafo)
    then begin x.Chave := j;  Enfileira (x, Fila); end;
    j := j + 1;
    end;
  while not Vazia (Fila) and (NArestas > 0) do
  begin
  Desenfileira (Fila, x);
  if Grafo.Prim[x.Chave] >= 0 
  then begin
       A1 := Grafo.Prim[x.Chave] mod Grafo.NumArestas;
       Aresta := RetiraAresta (Grafo.Arestas[A1], Grafo);
       L[Grafo.NumArestas - NArestas] := Aresta;
       NArestas := NArestas - 1;
       if NArestas > 0
       then for j := 0 to Grafo.r - 1 do
            if VerticeGrauUm (Aresta.Vertices[j], Grafo)
            then begin 
	          x.Chave := Aresta.Vertices[j]; 
              Enfileira (x, Fila); 
            end;
       end;
  end;
  { else writeln ('Nao ha vertices de grau 1 no grafo'); }
  GAciclico := NArestas = 0;
end; { GrafoAciclico }

{--Operadores para obter a lista de arestas incidentes a um vertice--}
function ListaIncVazia (var Vertice: TipoValorVertice;
                       var Grafo: TipoGrafo): boolean;
begin ListaIncVazia := Grafo.Prim[Vertice] = INDEFINIDO; end;

function PrimeiroListaInc (var Vertice: TipoValorVertice;
                           var Grafo: TipoGrafo): TipoApontador;
begin PrimeiroListaInc := Grafo.Prim[Vertice]; end;

procedure ProxArestaInc (var Vertice: TipoValorVertice; 
                         var Grafo: TipoGrafo;
                         var Inc: TipoValorAresta;
                         var Peso: TipoPesoAresta;
                         var Prox: TipoApontador;
                         var FimListaInc: boolean);
{--Retorna Inc apontado por Prox--}
begin
  Inc := Prox mod Grafo.NumArestas;  Peso := Grafo.Arestas[Inc].Peso;
  if Grafo.Prox[Prox] = INDEFINIDO 
  then FimListaInc := true
  else Prox := Grafo.Prox[Prox];
end;
{---- Fim dos operadores do Programa 7.? ----}

{ -Funcao hash universal apresentada no Programa 4.22- }
function h (Chave: TipoChave; p: TipoPesos): TipoIndice;
var
  i, Soma: integer;
begin
  Soma := 0;
  for i := 1 to MAXTAMCHAVE do 
    Soma := Soma + ord (Chave[i]) * p[i];
  h := Soma mod M;
end; { h }

{-Gera pesos para funcao h apresentado no Programa 6.X -}
procedure GeraPesos (var p: TipoPesos);
{ -Gera valores randomicos entre 1 e 10.000- }
var i: integer;
begin
  for i:= 1 to MAXTAMCHAVE do p[i] := random (10000)+1;
end;

Procedure Atribuig (var Grafo: TipoGrafo;
                    var L    : TipoArranjoArestas;
		    var g    : Tipog);
var 
  i, u, Soma: integer;
  v: TipoValorVertice; a: TipoAresta;
begin
  for i := Grafo.NumVertices - 1 downto 0 do g[i] := INDEFINIDO;
  for i := Grafo.NumArestas - 1 downto 0 do
    begin
    a := L[i];  Soma := 0;
    for v := Grafo.r - 1 downto 0 do
      if g[a.Vertices[v]] = INDEFINIDO
      then begin
           u := a.Vertices[v];
           g[u] := Grafo.NumArestas;
	   end
      else Soma := Soma + g[a.Vertices[v]];
    g[u] := a.Peso - Soma;
    if g[u] < 0 then g[u] := g[u] + (Grafo.r-1) * Grafo.NumArestas;
    end;
end; { -Fim Atribuig- }

procedure GeraGrafo (var ConjChaves    : TipoConjChaves;
                     N                 : TipoValorAresta;
                     M                 : TipoValorVertice;
		     r                 : Tipor;
                     var Pesos         : TipoTodosPesos;
                     var NgrafosGerados: integer;
                     var Grafo         : TipoGrafo); 
{ Gera um grafo sem arestas repetidas e sem self-loops }
var i, j: integer;  Aresta: TipoAresta;  GrafoValido: boolean;

  function VerticesIguais (Aresta: TipoAresta): boolean;
  var i, j: integer;
  begin
    VerticesIguais := false;
    for i := 0 to Grafo.r - 2 do
      for j := i + 1 to Grafo.r - 1 do
        if Aresta.Vertices[i] = Aresta.Vertices[j]
        then VerticesIguais := true; 
  end;

begin { -GeraGrafo- }
  repeat
    GrafoValido := true;    Grafo.NumVertices := M;
    Grafo.NumArestas := N;  Grafo.r := r;
    FGVazio (Grafo);         NGrafosGerados := 0;
    for j := 0 to Grafo.r - 1 do GeraPesos (Pesos[j]); 
    for i := 0 to Grafo.NumArestas - 1 do
      begin
      Aresta.Peso := i;
      for j := 0 to Grafo.r - 1 do
	Aresta.Vertices[j] := h (ConjChaves[i], Pesos[j]);
      if VerticesIguais (Aresta) or ExisteAresta (Aresta, Grafo)
      then begin GrafoValido := false;  break;  end
      else InsereAresta (Aresta, Grafo);
      end;
    NGrafosGerados := NGrafosGerados + 1;
 until GrafoValido;
end; { Fim GeraGrafo }

begin { -ObtemHashPerfeito- }
  randomize; {---Inicializa randon para 2^32 valores ---}
  write ('Nome do arquivo com chaves a serem lidas: ');
  readln (NomeArq);  assign (ArqEntrada, NomeArq);
  write ('Nome do arquivo para gravar experimento: '); readln(NomeArq);
  assign (ArqSaida, NomeArq);  reset (ArqEntrada);
  rewrite (ArqSaida);
  NGrafosGerados := 0;  i := 0;
  readln (ArqEntrada, N, M, r);
  while (i < N) and (not eof(ArqEntrada)) do
    begin readln (ArqEntrada, ConjChaves[i]);  i := i + 1;  end;
  if (i <> N)
  then begin
       writeln ('Erro: entrada com menos do que ', N, ' elementos.');
       exit;
       end;
  repeat 
    GeraGrafo (ConjChaves, N, M, r, Pesos, NgrafosGerados, Grafo); 
    ImprimeGrafo (Grafo);
    {--Imprime estrutura de dados--}
    write ('prim: '); for i:=0 to Grafo.NumVertices - 1 do 
      write (Grafo.Prim[i]:3); writeln;
    write ('prox: '); for i:=0 to Grafo.NumArestas*Grafo.r-1 do 
      write (Grafo.prox[i]:3); writeln;
    GrafoAciclico (Grafo, L, GAciclico);
  until GAciclico;
write ('Grafo aciclico com arestas retiradas:');
for i := 0 to Grafo.NumArestas - 1 do write (L[i].Peso:3);
writeln;
  Atribuig (Grafo, L, g);  
  writeln (ArqSaida, N, '  (N)');
  writeln (ArqSaida, M, '  (M)');
  writeln (ArqSaida, r, '  (r)');
  for j := 0 to Grafo.r - 1 do
    begin
    for i := 1 to MAXTAMCHAVE do write (ArqSaida, Pesos[j][i],' '); 
    for i := 1 to MAXTAMCHAVE do write (Pesos[j][i],' '); 
    writeln (ArqSaida, '  (p',j:1,')'); 
    writeln (' (p',j:1,')'); 
    end;
  for i := 0 to M - 1 do write (ArqSaida, g[i],' '); 
  for i := 0 to M - 1 do write (g[i],' '); 
  writeln (ArqSaida, '  (g)');  
  writeln ('  (g)');
  writeln(ArqSaida,'No. grafos gerados por GeraGrafo:',NGrafosGerados);
  close (ArqSaida);
  close (ArqEntrada);
end. { ObtemHashPerfeito }