Cod sursa(job #733195)

Utilizator elffikkVasile Ermicioi elffikk Data 11 aprilie 2012 16:31:44
Problema Elementul majoritar Scor 10
Compilator fpc Status done
Runda Arhiva educationala Marime 1.13 kb
var a:array[1..1000000] of longint;
n:longint;

procedure init;
var i:longint; f:text;
begin
  assign(f, 'elmaj.in');
  reset(f);
  read(f,n);
  for i:=1 to n do read(f,a[i]);
  close(f);
end;

procedure sw(var x,y:longint);
var t:longint;
begin
  t:=x;
  x:=y;
  y:=t;
end;

procedure afis;
var i:longint;
begin
  for i:=1 to n do write(a[i],' ');writeln;
end;

procedure qs(left, right:longint);
var i,j,p:longint;
begin
  i:=left; j:=right; p:=a[(i+j) div 2];
  while i<j do
  begin
    while a[i]<p do inc(i);
    while a[j]>p do dec(j);
    if i<=j then begin
      sw(a[i],a[j]);
      inc(i); dec(j);
    end;
  end;
  if j-left+1>=n div 2 then qs(left, j);
  if right-i+1>=n div 2 then qs(i,right);
end;

procedure fin;
var r,nr,k,i:longint; f:text;
begin
  r:=-1;
  nr:=0;
  k:=1;
  for i:=2 to n do
    if a[i]=a[i-1]
    then inc(k)
    else
    begin
      if k>n div 2 then begin r:=a[i-1]; nr:=k; end;
      k:=1;
    end;
  assign(f,'elmaj.out');
  rewrite(f);
  if r=-1
  then write(f,-1)
  else write(f,r,' ',nr);
  close(f);
end;

begin
  init;
  qs(1,n);
  fin;
end.