Cod sursa(job #801524)

Utilizator elffikkVasile Ermicioi elffikk Data 24 octombrie 2012 16:57:36
Problema Elementul majoritar Scor 0
Compilator fpc Status done
Runda Arhiva educationala Marime 1.65 kb
const maxn=1000000;
var f1:text;
    i,n,k,an:longint;
    left,right,val:array[1..maxn] of longint;

procedure sett(k,v:longint);
var c:byte; p:longint;
begin
  p:=1;
  repeat
    c:=k mod 2;
    k:=k div 2;
    if (c=0)and(left[p]=0)or(c=1)and(right[p]=0)
    then
    begin
      inc(an);
      left[an]:=0;
      right[an]:=0;
      val[an]:=0;
      if c=0
      then left[p]:=an
      else right[p]:=an;
      p:=an;
    end
    else
    begin
      if c=0
      then p:=left[p]
      else p:=right[p];
    end;
  until k<=0;
  val[p]:=v;
end;

function gett(k:longint):longint;
var p:longint; c:byte;
begin
  p:=1;
  repeat
    c:=k mod 2;
    k:=k div 2;
    if (c=0)and(left[p]=0)or(c=1)and(right[p]=0)
    then
    begin
      inc(an);
      left[an]:=0;
      right[an]:=0;
      val[an]:=0;
      if c=0
      then left[p]:=an
      else right[p]:=an;
      p:=an;
    end
    else
    begin
      if c=0
      then p:=left[p]
      else p:=right[p];
    end;
  until (k=0)or(c=0)and(left[p]=0)or(c=1)and(right[p]=0);
  if c=0
  then if left[p]=0 then gett:=0
       else gett:=val[left[p]]
  else
       if right[p]=0 then gett:=0
       else gett:=val[right[p]];
end;

procedure afist;
var i:longint;
begin
  for i:=1 to an do write(left[i]:3);writeln;
  for i:=1 to an do write(right[i]:3);writeln;
  for i:=1 to an do write(val[i]:3);writeln;
end;

begin
  an:=1; left[1]:=0;right[1]:=0;val[1]:=0;
  assign(f1, 'elmaj.in');
  reset(f1);
  readln(f1, n);
  for i:=1 to n do
  begin
    read(f1, k);
    write(k,' ');
    sett(k,gett(k)+1);
  end;
  writeln;
  afist;
  readln;
end.