Cele mai bune solutii pentru problema "Critici"
(ziua2, problema3)

Punctaj Maxim : 75 puncte

Solutii :
Podeanu Dan - Bucuresti - 75 puncte
Dumitrescu Bogdan - Prahova - 55 puncte
Nicolescu Mihai - Brasov - 55 puncte
Comisia Centrala
Fisierele de teste

Program realizat de elevul Podeanu Dan - rezultat final : premiu II - 112 puncte

{$A+,B-,D+,E+,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 65520,0,655360}

type
  critic = array[0..20] of byte;
  critic_list = array[1..100] of critic;
  adiacenta = array[1..100, 1..100] of byte;
  big_adiacenta = array[1..102, 1..102] of byte;

var
  c, r: byte;
  cl: critic_list;
  a: adiacenta;
  b, b2: big_adiacenta;
  s, t: byte; n: byte;

procedure InitData;
begin
  fillchar(cl, sizeof(cl), 0);
  fillchar(a, sizeof(a), 0);
end;

procedure ReadData;
var
  fin: text;
  i: integer;
begin
  assign(fin, 'CRITICI.IN'); reset(fin);
  read(fin, c); readln(fin, r);
  for i := 1 to c do begin
    cl[i][0] := 0;
    while(not(eoln(fin))) do begin
      inc(cl[i][0]);
      read(fin, cl[i][cl[i][0]]);
    end;
    readln(fin);
  end;
  close(fin);
end;

function QueryMatch(x, y: byte): boolean;
type
  hash = array[1..20] of byte;
var
  ii: byte;
  diffs: integer;
  v1, v2: critic;
  h: hash;

function GetMin(first, second: byte): byte;
begin
  if(first < second) then GetMin := first else GetMin := second;
end;

begin
  if(abs(cl[x][0] - cl[y][0]) <> 1) then begin
    QueryMatch := false;
    exit;
  end;
  ii := 1;
  diffs := 0;
  fillchar(h, sizeof(h), 0);
  if(cl[x][0] < cl[y][0]) then begin
    v1 := cl[x]; v2 := cl[y];
  end else begin
    v1 := cl[y]; v2 := cl[x];
  end;
  for ii := 1 to v1[0] do
    h[v1[ii]] := 1;
  for ii := 1 to v2[0] do
     if(h[v2[ii]] = 0) then inc(diffs);
  if(diffs = 1) then QueryMatch := true else QueryMatch := false;
end;

procedure MakeAdiacenta;
var
  i, j: integer;
begin
  for i := 1 to c do
    for j := (i + 1) to c do
      if(QueryMatch(i, j)) then begin
        a[i, j] := 1; a[j, i] := 1;
      end else begin
        a[i, j] := 0;
        a[j, i] := 0;
      end;
end;

function GetPos(x: byte): byte;
begin
  GetPos := x + 1;
end;

function GetS: byte;
begin
  GetS := 1;
end;

function GetT: byte;
begin
  GetT := c + 2;
end;

procedure MakeFluxInitialData;
var
  i, j: integer;
begin
  for i := 1 to c do begin
    for j := (i + 1) to c do
      if(a[i, j] = 1) then begin
{        writeln(i, ' ', j);}
        if((cl[i][0] mod 2) = 1) then
          b[GetPos(i), GetPos(j)] := 1 else
            b[GetPos(j), GetPos(i)] := 1;
      end;
    if((cl[i][0] mod 2) = 1) then b[GetS, GetPos(i)] := 1 else
      b[GetPos(i), GetT] := 1;
  end;
end;

{ ######### FLUX ######### }
procedure FluxIt;
type
  reached_set = set of byte;
  path_array = array[1..256] of byte;

var
  reached: reached_set;
  path: path_array;
  atpath: integer;
  FindT: boolean;
  i: integer;
  min: integer;

procedure Way(from: byte; at: byte);
var
  i: integer;
begin
  path[at] := from;
  reached := reached + [from];
  if(from = t) then begin
    FindT := true;
    atpath := at;
    exit;
  end;
  for i := 1 to n do
    if((b[from, i] = 1) and not(i in reached) and not(FindT)) then
      Way(i, at + 1);
end;

begin
  repeat
    atpath := 0;
    reached := []; FindT := false;
    Way(s, atpath + 1);
    if(FindT) then begin
      min := 32767;
      for i := 1 to atpath - 1 do
        if(b[path[i], path[i + 1]] < min) then
          min := b[path[i], path[i + 1]];
      if(min = 32767) then begin
        writeln('Error: invalid min at flux.');
        halt;
      end;
      for i := 1 to atpath - 1 do begin
        dec(b[path[i], path[i + 1]], min);
        inc(b[path[i + 1], path[i]], min);
      end;
    end;
  until(not(FindT));
end;

{ ######### WRITE RESULT ######### }
procedure WriteResult;
var
  i, j: integer;
  fout: text;
  count: integer;
begin
  assign(fout, 'CRITICI.OUT'); rewrite(fout);
  count := 0;
  for i := GetPos(1) to GetPos(c) do
    for j := GetPos(1) to GetPos(c) do
      if(b[i, j] - b2[i, j] = -1) then inc(count);
  writeln(fout, count);
  for i := GetPos(1) to GetPos(c) do
    for j := GetPos(1) to GetPos(c) do
      if(b[i, j] - b2[i, j] = -1) then writeln(fout, i - 1, ' ', j - 1);
  close(fout);
end;

begin
  InitData;
  ReadData;
  MakeAdiacenta;
  fillchar(b, sizeof(b), 0); fillchar(b2, sizeof(b2), 0);
  MakeFluxInitialData;
  b2 := b;
  s := GetS; t := GetT; n := c + 2;
  FluxIt;
  WriteResult;
end.

[BACK]

Program realizat de Comisia Centrala a Olimpiadei Nationale de Informatica

[BACK]

Fisierele de teste :

[BACK]