Задача про точки и отрезки Опции

[c-ch]

Точки и отрезки
(Время: 2 сек. Память: 16 Мб Сложность: 62%)
Дано N отрезков на числовой прямой и M точек на этой же прямой. Для каждой из данных точек определите, скольким отрезкам она принадлежит. Точка x считается принадлежащей отрезку с концами a и b, если выполняется двойное неравенство min(a, b) <= x <= max(a, b).

Входные данные

Первая строка входного файла INPUT.TXT содержит два целых числа N – число отрезков и M – число точек (1 <= N, M <= 10^5). В следующих N строках по два целых числа ai и bi – координаты концов соответствующего отрезка. В последней строке M целых чисел – координаты точек. Все числа во входном файле не превосходят по модулю 10^9.

Выходные данные

В выходной файл OUTPUT.TXT выведите M чисел – для каждой точки количество отрезков, в которых она содержится.

ПРИМЕРЫ
3 2
0 5
-3 2
7 10
1 6
ответ 2 0

1 3
-10 10
-100 100 0
ответ 0 0 1

Моя идея проста: сначала сортируем точки по координате, затем точки с одинаковой координатой сортируем по типу
К сожалению, этот вариант не проходит автоматическую систему проверки по времени (~+0,5сек)
Самого теста у меня нет
Вероятно, надо прикрутить упорядочивание по типу точки в процедуру сортировки по координате, но я не представляю, как это сделать...
А может ещё какой-то вариант есть?
Времени у меня как всегда впритык

program Project1;

type
  tip=(_left,_none,_right);
  point=record x,n,c:longint; t:tip end;
  mas=array [1..300000]of point;
var
  a,b:mas;
  f:text;
  i,n,m,k,j:longint;
  t:point;

procedure quicksort(var a: mas; Lo,Hi: integer);
  procedure sort(l,r: integer);
  var
    i,j: integer;
    x,y:point;
  begin
    i:=l; j:=r;  x := a[(r+l) div 2];
    repeat
      while a[i].x<x.x do i:=i+1; 
      while x.x<a[j].x do j:=j-1; 
      if i<=j then
      begin
        if a[i].x > a[j].x then 
        begin
          y:=a[i]; a[i]:=a[j]; a[j]:=y
        end;
        i:=i+1; j:=j-1
      end;
    until i>j;
    if l<j then sort(l,j);
    if i<r then sort(i,r)
  end; 
begin 
  sort(Lo,Hi)
end; 

procedure Tquicksort(var a: mas; Lo,Hi: integer);
  procedure sort(l,r: integer);
  var
    i,j: integer;
    x,y:point;
  begin
    i:=l; j:=r;  x := a[(r+l) div 2];
    repeat
      while a[i].t<x.t do i:=i+1; 
      while x.t<a[j].t do j:=j-1; 
      if i<=j then
      begin
        if a[i].t > a[j].t then 
        begin
          y:=a[i]; a[i]:=a[j]; a[j]:=y
        end;
        i:=i+1; j:=j-1
      end;
    until i>j;
    if l<j then sort(l,j);
    if i<r then sort(i,r)
  end; 
begin 
  sort(Lo,Hi)
end; 

begin
assign(f,'input.txt');
reset(f);
readln(f,n,m);
k:=1;
for I := 1 to n do {читаем отрезки}
    begin
    readln(f,a[k].x,a[k+1].x);
    a[k].t:=_left; a[k+1].t:=_right;
    inc(k,2)
    end;
for I := 1 to m do {читаем точки}
  begin
  read(f,a[k].x);
  a[k].t:=_none;
  a[k].n:=i;
  inc(k)
  end;
close(f);
quicksort(a,1,k-1); {сортируем все точки по координате}
for i := 1 to k - 2 do
  if a[i].x=a[i+1].x then {находим последовательность точек с одинаковой координатой...}
    begin
    j:=i+1;
    while a[i].x=a[j].x do
      inc(j);
    tquicksort(a,i,j-1) {...и сортируем её по типу: сначала должны идти _left, затем _none, затем _right}
    end;
j:=0;
for I := 1 to k-1 do {считаем количество вхождений точки в отрезки}
  case a[i].t of
  _none:begin a[i].c:=j; b[a[i].n]:=a[i] end;
  _left:inc(j);
  _right:dec(j)
  end;
assign(f,'output.txt');
rewrite(f);
for i := 1 to m do
  if b[i].n>0 then write(f,b[i].c,' ');
close(f)
end.

Заранее спасибо

Сообщение отредактировано: c-ch - 5.04.2009 20:18

[c-ch]

ещё один вариант сделал: разводим начала и концы отрезков в разные массивы, оба упорядичиваем и для каждой точки бинарным поиском ищем сколько начал отрезков левее её (не строго) и сколько правее (строго). Их разность является ответом.
Вроде и сортировка и поиск достаточно быстрые, но всё равно по времени не укладывается

program Project1;
uses math;
type arrtype=array[1..100000]of longint;
var
  l,r,p:arrtype;
  i,j,n,m,t1,t2:longint;
  f:text;

Procedure quicksort(Var ar: arrType; n: integer);
  Procedure sort(m, l: Integer);
  Var i, j, x, w: Integer;
  Begin
    i := m; j := l;
    x := ar[(m+l) div 2];
    Repeat
      While ar[i] < x Do Inc(i);
      While ar[j] > x Do Dec(j);
      If i <= j Then Begin
        w := ar[i]; ar[i] := ar[j]; ar[j] := w;
        Inc(i); Dec(j)
      End
    Until i > j;
    If m < j Then Sort(m, j);
    If i < l Then Sort(i, l)
  End;
Begin
  sort(1, n)
End;

function FindIt(x:longint):longint;

  function FindInLeft:longint;
  var left,right,middle:longint;
  begin
  if x<l[1] then result:=0
  else
  if x>l[n] then result:=n
  else
    begin
    left:=1; right:=n;
    repeat
    middle:=(right+left) div 2;
    if l[middle]>x then right:=middle
    else
    if l[middle]<x then left:=middle
    until (l[middle]<=x)or(right-left=1);
    while (l[middle]<=x)and(middle<=n) do inc(middle);
    result:=middle-1;
    end;
  end;

  function FindInRight:longint;
  var left,right,middle:longint;
  begin
  if x<r[1] then result:=0
  else
  if x>r[n] then result:=n
  else
    begin
    left:=1; right:=n;
    repeat
    middle:=(right+left) div 2;
    if r[middle]>x then right:=middle
    else
    if r[middle]<x then left:=middle
    until (r[middle]<=x)or(right-left=1);
    while (r[middle]>=x)and(middle<=n) do dec(middle);
      result:=middle;
    end;
  end;

begin
result:=abs(findinleft-findinright)
end;

begin
assign(f,'input.txt');
reset(f);
readln(f,n,m);
for i := 1 to n do
  begin
  readln(f,t1,t2);
  l[i]:=min(t1,t2);
  r[i]:=max(t1,t2);
  end;
for I := 1 to m do read(f,p[i]);
close(f);
quicksort(l,n);
quicksort(r,n);
assign(f,'output.txt');
rewrite(f);
for I := 1 to m do write(f,findit(p[i]),' ');
close(f);
end.