MILITARY - Câu chuyện người lính

Tác giả: RR

Ngôn ngữ: Pascal

//Wishing myself a happy lunar new year with a lot of accept solutions
//Written by Nguyen Thanh Trung
{$R+,Q+}
PROGRAM MILITARY;
CONST
  fi='';
  fo='';
  maxn=4000;
  esp=0.000001;
TYPE
  rec=record x,y:real; ind:integer; end;
VAR
  n,c,m,kq:integer;
  a,b:array[1..maxn] of rec;
Procedure ReadInput;
Var
  f:text;
  i:integer;
Begin
  Assign(f,fi); Reset(f);
  Readln(f,n);
  For i:=1 to n do
  with a[i] do
    begin
      Readln(f,x,y);
      ind:=i;
    end;
  Close(f);
End;
Procedure WriteOutput;
Var
  f:text;
Begin
  Assign(f,fo); Rewrite(f);
  Writeln(f,kq);
  Close(f);
End;
Procedure Swap(var p1,p2:rec);
Var
  temp:rec;
Begin
  temp:=p1; p1:=p2; p2:=temp;
End;
Function CCW(p1,p2,p3:rec):integer;
Var
  t,a1,a2,b1,b2:real;
Begin
  a1:=p2.x-p1.x;
  b1:=p2.y-p1.y;
  a2:=p3.x-p2.x;
  b2:=p3.y-p2.y;
  t:=a1*b2-a2*b1;
  If abs(t)<esp then CCW:=0
  else if t<0 then CCW:=-1
  else CCW:=1;
End;
Function Lower(p1,p2:rec):boolean;
Var
  t,a1,a2,b1,b2:real;
Begin
  a1:=p1.x-a[1].x;
  b1:=p1.y-a[1].y;
  a2:=p2.x-a[1].x;
  b2:=p2.y-a[1].y;
  t:=a1*b2-a2*b1;
  Lower:=false;
  If (t>esp) then Lower:=true
  else If (abs(t)<esp) and ((p1.x<p2.x) or ((p1.x=p2.x) and (p1.y<p2.y)))
       then Lower:=true;
End;
Procedure Find;
Var
  i:integer;
Begin
  c:=1;
  For i:=2 to n do
    If (a[i].y<a[c].y) or ((a[i].y=a[c].y) and (a[i].x<a[c].x)) then
      c:=i;
End;
Procedure QuickSort;
  Procedure Sort(l,r:integer);
  Var
    i,j:integer;
    x:rec;
  Begin
    i:=l; j:=r; x:=a[(l+r) div 2];
    repeat
      while lower(a[i],x) do inc(i);
      while lower(x,a[j]) do dec(j);
      if i<=j then
        begin
          Swap(a[i],a[j]);
          inc(i); dec(j);
        end;
    until i>j;
    if i<r then Sort(i,r);
    if l<j then Sort(l,j);
  End;
Begin
  If n>2 then Sort(2,n);
End;
Procedure Graham;
Var
  i:integer;
Begin
  m:=2; b[1]:=a[1]; b[2]:=a[2];
  b[1].ind:=1; b[2].ind:=2;
  For i:=3 to n do
    begin
      while (m>1) and (CCW(b[m-1],b[m],a[i])=-1) do dec(m);
      inc(m);
      b[m]:=a[i];
      b[m].ind:=i;
    end;
End;
Procedure Kt;
Var
  i:integer;
  mm:integer;
Begin
  mm:=m; m:=2;
  For i:=3 to mm do
    begin
      while (m>1) and (CCW(b[m-1],b[m],b[i])<>1) do dec(m);
      inc(m);
      b[m]:=b[i];
    end;
End;
Procedure LoaiDiem;
Var
  i,j:integer;
  n1:integer;
Begin
  For i:=1 to m do
    a[b[i].ind].ind:=-1;
  i:=1; j:=1; n1:=0;
  repeat
    while a[j].ind=-1 do inc(j);
    if j<n then
      begin
        a[i]:=a[j];
        inc(n1);
        inc(i); inc(j);
      end;
  until j>=n;
  n:=n1;
End;
Procedure Solve;
Begin
  kq:=0;
  repeat
    Find;
    Swap(a[c],a[1]);
    QuickSort;
    Graham;
    LoaiDiem;
    Kt;
    If m>2 then inc(kq)
    else exit;
  until m<=2;
End;
BEGIN
  ReadInput;
  Solve;
  WriteOutput;
END.

Download