Cod sursa(job #1089300)

Utilizator RusuAlexeiRusu Alexei RusuAlexei Data 21 ianuarie 2014 17:04:43
Problema Secv Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.42 kb
program subsir_crescator_maxim;
  var f1,f2:text;
      n,lmax,i,j,pmax,cont,pred:longint;
      a,l,min,d,p:array [0..5000] of longint;
      bufin,bufout:array [1..100000] of byte;
      left,right:longint;
      sir:array [1..5000] of longint;
      len:longint;
      ok,ok2:boolean;

procedure scrie(x:longint);
  begin
    if x<>0 then
      begin
        scrie(d[x]);
        inc(len);
        sir[len]:=a[x];

      end;
  end;
begin
  assign(f1,'secv.in');
  reset(f1);
  assign(f2,'secv.out');
  rewrite(f2);
  settextbuf(f1,bufin);
  settextbuf(f2,bufout);
  readln(f1,n);
  for i:=1 to n do read(f1,a[i]);
  for i:=1 to n do min[i]:=2000000001;
  for i:=1 to n do
    begin
      l[i]:=lmax;
      while (min[l[i]]>=a[i]) and (l[i]>0) do dec(l[i]);
      d[i]:=p[l[i]];
      inc(l[i]);
      if l[i]>lmax then begin lmax:=l[i]; pmax:=i; end;
      if a[i]<min[l[i]] then begin min[l[i]]:=a[i]; p[l[i]]:=i; end;
    end;
  right:=pmax;
  left:=right;pred:=right;cont:=lmax-1;
  while cont>0 do
    begin
      while a[left]>=a[pred] do
        begin
          dec(left);
        end;
      dec(cont);pred:=left;
    end;
  scrie(pmax);
  ok:=true;
  for i:=1 to n do
    begin
      ok2:=false;
      for j:=1 to lmax do
        if a[i]=sir[j] then ok2:=true;
      ok:=ok and ok2;
    end;
  if  ok then writeln(f2,right+1-left) else writeln(f2,-1);
  close(f1);
  close(f2);
end.