This is mine.
Program xir;
Var
  i,j,k,n,max:integer;
  fl:boolean;
  a,b,c,q:array [1..500] of integer;
  f:array [1..500,1..2] of integer;
Function compare(x,y:integer):boolean;
Begin
  fl:=false;
  If b[x]-a[x]+1<b[y]-a[y]+1 then fl:=true
    Else If b[x]-a[x]+1=b[y]-a[y]+1 then
           If a[x]<=b[x] then fl:=true;
  compare:=fl;
End;{compare}
Procedure Qsort(s,e:integer);
Begin
  If s<e then
  Begin
    i:=s;j:=e;k:=c[s];
    Repeat
      While compare(c[i],c[j]) and (i<j) do j:=j-1;
      If i<j then
      Begin
        c[i]:=c[j];
        i:=i+1;
      End;
      While compare(c[j],c[i]) and (i<j) do i:=i+1;
      If i<j then
      Begin
        c[j]:=c[i];
        j:=j-1;
      End;
    Until i=j;
    c[i]:=k;
    Qsort(s,i-1);
    Qsort(i+1,e);
  End;
End;{Qsort}
Begin
  readln(n);
  For i:=1 to n do
  Begin
    readln(a[i],b[i]);
    c[i]:=i;
  End;
  Qsort(1,n);
  max:=1;
  For i:=1 to n do
  Begin
    f[i,1]:=0;f[i,2]:=0;
    For j:=1 to i-1 do
    Begin
      If (a[c[j]]>a[c[i]]) and (b[c[j]]<b[c[i]]) then
      Begin
        If f[j,1]>f[i,1] then
        Begin
          f[i,1]:=f[j,1];
          f[i,2]:=j;
        End;
      End;
    End;
    inc(f[i,1]);
    If f[i,1]>f[max,1] then
      max:=i;
  End;
  writeln(f[max,1]);
  j:=0;
  Repeat
    j:=j+1;
    q[j]:=c[max];
    max:=f[max,2];
  Until max=0;
  For i:=j downto 2 do
    write(q[i],' ');
  write(q[1]);
End.

Please help me!!!