На прямой даны отрезки, найти самое короткое пересечение - Pascal ABC

Формулировка задачи:

Задача с http://informatics.mccme.ru/mod/statements/view3.php?chapterid=516#1 Недавно Петя занялся изучением древних цивилизаций. Он нашел в энциклопедии даты рождения и гибели N различных древних цивилизаций и теперь хочет узнать о влиянии культуры одних цивилизаций на культуру других. Петя предположил, что между цивилизациями A и B происходил культурный обмен, если они сосуществовали в течение некоторого ненулевого промежутка времени. Например, если цивилизация A зародилась в 600 году до н.э. и существовала до 400 года до н.э., а цивилизация B зародилась в 450 году до н.э. и существовала до 300 года до н.э., то культура каждой из этих цивилизаций оказывала влияние на развитие другой цивилизации в течение 50 лет. В то же время, если цивилизация C зародилась в 400 году до н.э. и существовала до 50 года до н.э., то она не смогла осуществить культурного обмена с цивилизацией A, в то время как культурный обмен с цивилизацией B продолжался в течение 100 лет. Теперь для выполнения своих исследований Петя хочет найти такую пару цивилизаций, культурный обмен между которыми имел место на протяжении наименьшего ненулевого промежутка времени. Помогите ему! Входные данные В первой строке вводится число N – количество цивилизаций, культура которых интересует Петю (1N100 000). Следующие N строк содержат описание цивилизаций – в каждой строке задаются два целых числа Si и Ei – год зарождения и год гибели соответствующей цивилизации. Все числа не превосходят 109 по абсолютной величине, Si < Ei. Выходные данные Выведите два числа – номера цивилизаций, периоды существования которых имеют наименьшее ненулевое пересечение. Если никакие две цивилизации не пересекаются во времени, выведите единственное число 0. Примеры входные данные 3 -600 -400 -450 -300 -400 -50 выходные данные 1 2 входные данные 2 10 20 15 21 выходные данные 1 2 входные данные 1 77777 77778 выходные данные 0 моя попытка:

var
  n, i, k, sum, min, min1, one, duo: integer; 
  mass1, mass2, mass3: array [1..1000000] of longint;
 
{procedure sort(l,r:longint); 
var i,j,n:longint; 
x,y:longint; 
begin 
i:=l; 
j:=r; 
m:=(l+r)/l+(random(r-l); 
x:=mass[mass1,2] 
end; } 
 
procedure Quicksort(Left, Right: integer);
var
  ptrLeft, ptrRight, Pivot, Temp: integer;
begin
  ptrLeft := Left; 
  ptrRight := Right; 
  Pivot := mass1[(Left + Right) div 2]; 
  repeat
    while (ptrLeft < Right) and (mass1[ptrLeft] < Pivot) do 
      inc(ptrLeft); 
    while (ptrRight > Left) and (mass1[ptrRight] > Pivot) do 
      dec(ptrRight); 
    if ptrLeft <= ptrRight then 
    begin
      if ptrLeft < ptrRight then 
      begin
        Temp := mass1[ptrLeft]; 
        mass1[ptrLeft] := mass1[ptrRight]; 
        mass1[ptrRight] := Temp; 
        Temp := mass2[ptrLeft]; 
        mass2[ptrLeft] := mass2[ptrRight]; 
        mass2[ptrRight] := Temp; 
        Temp := mass3[ptrLeft]; 
        mass3[ptrLeft] := mass3[ptrRight]; 
        mass3[ptrRight] := Temp; 
      end; 
      inc(ptrLeft); 
      dec(ptrRight); 
    end; 
  until ptrLeft > ptrRight; 
  if ptrRight > Left then 
    Quicksort(Left, ptrRight); 
  if ptrLeft < Right then 
    Quicksort(ptrLeft, Right); 
end;
 
begin
  read(n); 
  if n = 1 then  write('0') else begin
    k := 1; 
    for i := 1 to n * 2 do 
    begin
      read(mass1[i]); 
      mass3[i] := k;
      if i mod 2 = 0 then begin mass2[i] := -1; k := k + 1; end else mass2[i] := 1; 
    end; 
    
    quicksort(1, n * 2); 
    sum := 0; 
    min1 := 1000000; 
    one := 0; 
    duo:=0;
    for i := 1 to n * 2 do 
    begin
      sum := sum + mass2[i]; 
      //if mass2[i]<0 then write(']') else write('[');
      if (sum <> 0) and (mass2[i] < 0) and ((mass1[i] - mass1[i - 1]) <> 0) then begin
        min := mass1[i] - mass1[i - 1]; 
        if min < min1 then begin
          one:=mass3[i - 1];
          duo:=mass3[i];
        min1 := min;
        end;
      end; 
    end;
  end;
  if one < duo then 
            writeln(one, ' ', duo) else 
            writeln(duo, ' ', one);
end.

Решение задачи: «На прямой даны отрезки, найти самое короткое пересечение»

Листинг программы

Const
    maxn =   100000;
    minc =   -1000000000;
    maxc =   1000000000;
 
Var
    a, s:   array [1..2 * maxn] Of longint;
    l, r:   array [1..maxn] Of longint;
    n:   longint;
 
Procedure sort(l, r: longint);
 
Var
    i, j, x, t:   longint;
Begin
    i := l;
    j := r;
    x := a[l + random(r - l + 1)];
 
    While i <= j Do
        Begin
            While a[i] < x Do
                inc(i);
            While a[j] > x Do
                dec(j);
            If i <= j Then
                Begin
                    t := a[i];
                    a[i] := a[j];
                    a[j] := t;
                    t := s[i];
                    s[i] := s[j];
                    s[j] := t;
                    inc(i);
                    dec(j);
                End;
        End;
 
    If l < j Then sort(l, j);
    If i < r Then sort(i, r);
End;
 
Var
    i, j, k, m, p, q, best, t:   longint;
    u:   array [1..maxn] Of boolean;
 
Begin
   // assign(input, 'input.txt');
   // reset(input);
   // assign(output, 'output.txt');
   // rewrite(output);
   read(n);
   readln;
 
    m := 0;
    For i := 1 To n Do
        Begin
            read(l[i]);
            read(r[i]);
            readln;
 
            inc(m);
            a[m] := 2 * l[i];
            s[m] := i;
            inc(m);
            a[m] := 2 * r[i] - 1;
            s[m] := i;
        End;
 
    sort(1, m);
 
    k := 0;
    best := 0;
    p := 0;
    q := 0;
    j := 0;
    For i := 1 To m Do
        Begin
            If a[i] Mod 2 = 0 Then
                Begin
                    inc(k);
                    If (k > 1) And (a[i + 1] Mod 2 <> 0) Then
                        Begin
                            t := (a[i + 1] + 1) Div 2 - a[i] Div 2;
                            If (best = 0) Or (t < best) Then
                                Begin
                                    best := t;
                                    j := i;
                                    p := s[i];
                                    q := s[i + 1];
                                End;
                        End;
                End
            Else
                Begin
                    dec(k)
                End;
        End;
 
    If best = 0 Then
        Begin
            writeln(0)
        End
    Else
        Begin
            // writeln(best);
 
            If q = p Then
                Begin
                    For i := 1 To j Do
                        Begin
                            If a[i] Mod 2 = 0 Then
                                u[s[i]] := true
                            Else
                                u[s[i]] := false;
                        End;
 
                    For i := 1 To n Do
                        If (i <> p) And u[i] Then
                            q := i;
                End;
                if p<q then
            writeln(p, ' ',q)
            else writeln(q, ' ',p);
        End;
 
   // close(input);
   // close(output);
End.

Объяснение кода листинга программы

Код написан на языке Pascal ABC и предназначен для поиска самого короткого пересечения отрезков. В нем используются следующие константы: Const maxn = 100000; minc = -1000000000; maxc = 1000000000; Var a, s: array[1..2 maxn] Of longint; l, r: array[1..maxn] Of longint; n: longint; Procedure sort(l, r: longint); Var i, j, x, t: longint; Begin i := l; j := r; x := a[l + random(r - l + 1)]; While i <= j Do Begin While a[i] < x Do inc(i); While a[j] > x Do dec(j); If i <= j Then Begin t := a[i]; a[i] := a[j]; a[j] := t; t := s[i]; s[i] := s[j]; s[j] := t; inc(i); dec(j); End; End; If l < j Then sort(l, j); If i < r Then sort(i, r); End; Var i, j, k, m, p, q, best, t: longint; u: array[1..maxn] Of boolean; Begin // assign(input, 'input.txt'); // reset(input); // assign(output, 'output.txt'); // rewrite(output); read(n); readln; m := 0; For i := 1 To n Do Begin read(l[i]); read(r[i]); readln; inc(m); a[m] := 2 l[i]; s[m] := i; inc(m); a[m] := 2 * r[i] — 1; s[m] := i; End; sort(1, m); k := 0; best := 0; p := 0; q := 0; j := 0; For i := 1 To m Do Begin If a[i] Mod 2 = 0 Then Begin inc(k); If (k > 1) And (a[i + 1] Mod 2 <> 0) Then Begin t := (a[i + 1] + 1) Div 2 - a[i] Div 2; If (best = 0) Or (t < best) Then Begin best := t; j := i; p := s[i]; q := s[i + 1]; End; End; End; If best = 0 Then Begin Writeln(0); End Else Begin If q = p Then Begin For i := 1 To j Do Begin If a[i] Mod 2 = 0 Then u[s[i]] := true; Else u[s[i]] := false; End; q := p; End; If p<q Then Writeln(p, ' ',q); Else Writeln(q, ' ',p); End; End; // close(input); // close(output); End.