Question

Trên hai đường thẳng song song L1 và L2 người ta đánh dấu trên mỗi đường N điểm. Các điểm trên đường thẳng L1 được đánh số từ 1 đến N từ trái qua phải, còn các điểm trên đường thẳng L2 được đánh số bằng p1, p2, ..., pn cũng từ trái qua phải với p1, p2, ..., pn là một hoán vị của 1, 2, ..., n (hình vẽ dưới dây cho 1 ví dụ khi n=9):

Ta gọi các số gán cho các điểm là số hiệu của chúng. Cho phép nối hai điểm trên hai đường thẳng có cùng số hiệu.

Yêu cầu: Tìm cách nối được nhiều cặp điểm nhất với điều kiện các đoạn nối không được cắt nhau.

Dữ liệu: Vào từ file văn bản WIRES.INP:

• Dòng đầu tiên chứa số nguyên dương N (Ns£1000)
• Dòng thứ hai chứa các số nguyên p1, p2, ..., pn cách nhau bởi dấu trắng

Kết quả: Ghi ra file văn bản WIRES.OUT:

• Dòng đầu tiên chứa k là số lượng các đoạn nối tìm được
• Dòng tiếp theo chứa k số hiệu của các đầu mút của các đoạn nối được ghi theo thứ tự tăng dần.

Ví dụ:

WIRES.INP	WIRES.OUT
9 2 5 3 8 7 4 6 9 1	5 2 3 4 6 9

Answer 1

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

{$M 16384,0,655360}

uses crt;

const
   tfi='WIRES.INP';
   tfo='WIRES.OUT';
   NN=1000;
   maxN=1000;

var
   fi,fo: text;
   N: integer;
   a: array[1..maxN] of integer;
   sl: array[1..maxN] of integer;
   tr: array[1..maxN] of integer;
   slx: integer;
   x: array[1..maxN] of integer;

procedure Sinhdl;
var ch: char;
    i,j,t: integer;
begin
   clrscr;
   writeln('Ban co tao file ',tfi,' (C/K)?');
   repeat ch:=readkey until upcase(ch) in ['C','K'];
   if upcase(ch)='K' then exit;
   randomize;
   N:=NN;
   for i:=1 to N do a[i]:=i;
   for i:=N downto 2 do
      begin
         j:=random(i)+1;
         t:=a[i];
         a[i]:=a[j];
         a[j]:=t;
      end;
   assign(fi,tfi); rewrite(fi);
   writeln(fi,N);
   for i:=1 to N do write(fi,a[i],' ');
   close(fi);
end;

procedure Docdl;
var i,u: integer;
begin
   assign(fi,tfi); reset(fi);
   readln(fi,N);
   for i:=1 to N do
      begin
         read(fi,u);
         a[u]:=i;
      end;
   close(fi);
end;

procedure XDB;
var i,j: integer;
begin
   sl[1]:=1; tr[1]:=-1;
   for i:=2 to N do
      begin
         sl[i]:=1; tr[i]:=-1;
         for j:=i-1 downto 1 do
            if (a[j]sl[u] then u:=i;
   slx:=0;
   repeat
      inc(slx);
      x[slx]:=u;
      u:=tr[u];
   until u=-1;
end;

procedure Inkq;
var i: integer;
begin
   assign(fo,tfo); rewrite(fo);
   writeln(fo,slx);
   for i:=slx downto 1 do write(fo,x[i],' ');
   close(fo);
end;

BEGIN
   {Sinhdl;}
   Docdl;
   XDB;
   XLB;
   Inkq;
END.