{ Data: 22/nov/09 }
{ Verifica se grafo e' aciclico, Atribuig usando 2 bits por entrada de g e gera a funcao hpm }
program GeraFuncaohpm;

const
  MAXK           = 256;
  MAXNUMVERTICES = 100000; {--No. maximo de vertices--}
  MAXTAMG        = Trunc((MAXNUMVERTICES + 3)/4); { Cada byte armazena 4 vertices }
  MAXTAMTABRANK  = Trunc((MAXNUMVERTICES + MAXK - 1)/MAXK); { Teto de MAXNUMVERTICES/MAXK }
  MAXTRVALUE     = 255;
  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;
  NAOATRIBUIDO   = 3;

type
  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;
  Apontador = 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 : Apontador;
                Tras   : Apontador;
              end;
  TipoPesos        = array [1..MAXTAMCHAVE] of integer;
  TipoTodosPesos   = array [Tipor] of Tipopesos;
  Tipog            = array[0..MAXTAMG] of byte; 
  TipoTr           = array[0..MAXTRVALUE] of byte;
  TipoTabRank      = array[0..MAXTAMTABRANK] of Integer;
  TipoK            = 4..MAXK;
  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; 
  Tr                 : TipoTr;
  TabRank            : TipoTabRank;
  TamTabRank         : Integer;
  k                  : TipoK;
  Pesos              : TipoTodosPesos;
  i, j               : integer;
  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): Apontador;
begin PrimeiroListaInc := Grafo.Prim[Vertice]; end;

procedure ProxArestaInc (var Vertice: TipoValorVertice; 
                         var Grafo: TipoGrafo;
                         var Inc: TipoValorAresta;
                         var Peso: TipoPesoAresta;
                         var Prox: Apontador;
                         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.26 --}

{-- Funcao hash universal apresentada no Programa 5.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 5.23 --}
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;

{ Assume que todas as entradas de 2 bits do vetor }
{ g foram inicializadas com o valor 3             }

procedure AtribuiValor2Bits (var g : Tipog; 
                             Indice: integer;
                             Valor : byte);
var i, Pos : integer;
begin
  i   := Indice div 4;
  Pos := (Indice mod 4);
  Pos := Pos * 2; { Cada valor ocupa 2 bits }
  g[i] := g[i] and (not(3 shl Pos)); { zera os dois bits a atribuir }
  g[i] := g[i] or (Valor shl Pos);   { realiza a atribuicao } 
end; {AtribuiValor2Bits}

function ObtemValor2Bits (var g : Tipog; 
                          Indice: Integer) : byte;
var i, Pos: Integer;
begin
  i := Indice div 4;
  Pos := (Indice mod 4);
  Pos := Pos * 2; { Cada valor ocupa 2 bits }
  ObtemValor2Bits := (g[i] shr Pos) and 3;  
end; {ObtemValor2Bits}

Procedure Atribuig (var Grafo: TipoGrafo;
                    var L    : TipoArranjoArestas;
                    var g    : Tipog);
var i, j, u    : integer;
    v          : TipoValorVertice;
    a          : TipoAresta;
    Soma       : integer;
    valorg2bits: integer;
    Visitado   : array[0..MAXNUMVERTICES] of boolean;
begin
  if (grafo.r <= 3) { valores de 2 bits requerem r <= 3} 
  then begin
       for i := Grafo.NumVertices - 1 downto 0 do 
         begin
         AtribuiValor2Bits (g, i, grafo.r);
         Visitado[i] := false;
         end;
       for i := Grafo.NumArestas - 1 downto 0 do
         begin
         a := L[i];
         Soma := 0;
         for v := Grafo.r - 1 downto 0 do
           if not Visitado[a.Vertices[v]]
           then begin
                Visitado[a.Vertices[v]] := true;
                u := a.Vertices[v];
                j := v;
                end
           else Soma := Soma + ObtemValor2Bits (g, a.Vertices[v]);
         valorg2bits := (j - Soma) mod grafo.r;
         AtribuiValor2Bits (g, u, valorg2bits);
         end;
       end;
end; { Atribuig }

Procedure GeraTr (var Tr: TipoTr);
var i, j, v, Soma: Integer;
begin
  Soma := 0;
  for i := 0 to MAXTRVALUE do
    begin
    Soma := 0;  v := i;
    for j := 1 to 4 do
      begin
      if ((v and 3) <> NAOATRIBUIDO) then Soma := Soma + 1;
      v := v shr 2; 
      end;
    Tr[i] := Soma;
    end;
end; { GeraTr }

Procedure ImprimeTr (var Tr: TipoTr);
var i : Integer;
begin
  write ('Tr = {');
  for i := 0 to MAXTRVALUE do
    begin
    if (i mod 16 = 0) then writeln;
    write (Tr[i], ' ');
    end;
  writeln;
  writeln ('}');
end; {ImprimeTr }

Procedure GeraTabRank (var g      : Tipog; 
                       Tamg       : TipoValorVertice;
                       k          : TipoK;
                       var TabRank: TipoTabRank);
var i, Soma: Integer;
begin
  Soma := 0;
  for i := 0 to Tamg - 1 do
    begin
    if (i mod k = 0) then TabRank[i div k] := Soma;
    if (ObtemValor2Bits(g, i) <> NAOATRIBUIDO) then Soma := Soma + 1; 
    end;
end; { GeraTabRank }

Procedure ImprimeTabRank (var TabRank   : TipoTabRank;
                         var TamTabRank: Integer);
var i : Integer;
begin
  write ('TabRank = {');
  for i := 0 to TamTabRank - 1 do
    begin
    if (i mod 16 = 0) then writeln;
    write (TabRank[i], ' ');
    end;
  writeln;
  writeln ('}');
end;

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: arquivo de entrada possui menos 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); 
  GeraTr (Tr);
  ImprimeTr (Tr);
  k := 4; {Fabiano: mudar para 256}
  GeraTabRank (g, Grafo.NumVertices, k, TabRank);
  TamTabRank := (Grafo.NumVertices + k - 1) div k;
 
  {-- Salvando a FHPM gerada --}
  writeln (ArqSaida, N, '  (N)');
  writeln (ArqSaida, M, '  (M)');
  writeln (ArqSaida, r, '  (r)');
  writeln (ArqSaida, k, '  (k)');
  
  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, ObtemValor2Bits (g, i), ' '); 
  for i := 0 to M - 1 do write (ObtemValor2Bits (g, i), ' '); 
  writeln (ArqSaida, '  (g)');  
  writeln ('  (g)');
  
  for i := 0 to TamTabRank - 1 do write (ArqSaida, TabRank[i], ' '); 
  for i := 0 to TamTabRank - 1 do write (TabRank[i], ' '); 
  writeln (ArqSaida, '  (TabRank)');  
  writeln ('  (TabRank)');
  
  writeln (ArqSaida, 'No. grafos gerados por GeraGrafo:', NGrafosGerados);
  close (ArqSaida);
  close (ArqEntrada);
end. { ObtemHashPerfeito }