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

[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.

[Lapp]

Вроде и сортировка и поиск достаточно быстрые, но всё равно по времени не укладывается

Я бы на твоем месте больше заботился о качестве самого кода. Например, вот тут:

  l[i]:=min(t1,t2);
  r[i]:=max(t1,t2);

- ты транжиришь время как будто у тебя есть вечность

[c-ch]

конкретно этот кусок я исправил ветвлением, спасибо
но толку-то никакого
либо есть что-то ещё, что я не вижу, либо одно из двух, как в анекдоте...

[volvo]

c-ch
Насколько я вижу, у тебя вся проблема - в реализации бинарного поиска. Ты выбрал, наверное, самый неэффективный способ. Попробуй вот так:

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 right-left > 1 do begin
          middle := (right+left) div 2;
          if l[middle] < x then left := middle
          else right := middle;
        end;
        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 right-left > 1 do begin
          middle := (right+left) div 2;
          if r[middle] < x then left := middle
          else right := middle;
        end;
        while (r[middle]>=x)and(middle<=n) do dec(middle);
        result:=middle;
      end;
    end;

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

Казалось бы, ничего не изменилось, ан нет...

[c-ch]

время улучшилось на пару сотых секунды
но этого мало
я уже начинаю подозревать систему проверки
хотя, люди как-то сдают...то ли лыжи не едут...

[volvo]

время улучшилось на пару сотых секунды

Да? У меня время уменьшилось с 8 секунд изначальных (n = m = 10⁵, случайные данные) до 0.06 сек после внесения изменений... Что-то у тебя не то происходит...

[c-ch]

я лишь привёл цифры, которые дала система проверки...
буду дальше думать

[passat]

Координаты отрезков записываем в массив. Держим вспомогательный признак: начало отрезка +1, конец -1. Сортируем массив. Сортируем массив точек. Дольше идем от наименьшего в двух массивах. Сумма +1 будет давать количетво отрезков, которым принадлежит точка.

Такой алгоритм подойдет?

[passat]

Точнее, даже так. Все сливаем в один массив. ВВодим признаки: +1 - начало отрезка, 0 - точка, -1 - конец отрезка. Сортируем массив. Далее идем от начала к концу и подсчитываем суммы +1, -1, и 0. На каждом нуле запоминаем сумму.

Работать должно за время сортировки плюс полного прохода по массиву, т.е. O((2*N+M)*(1+log(2*N+M)))

Несколько ускорить может внутренняя проверка на исчерпанность точек и отрезков.

Сработает?

[c-ch]

конечно
в первом посте именно такой вариант
кстати, оба варианта показывают одинаковое время
может таки это не мой косяк?

[volvo]

может таки это не мой косяк?

Может, ты все-таки дашь ссылку на сервер, на котором проверяешь код? А то борьба, похоже, идет с ветряными мельницами...

Ну, сгенерируй файл данных для макс. значений M, N и запусти у себя на машине твой второй и мой исправленный варианты решения. Сколько времени выполняется исправленный? Как может сервер выдавать тебе овертайм при разрешенном времени = 2 секунды (если он, конечно, вменяемый сервер)?

[c-ch]

пожалуйста: http://acmp.ru/index.asp?main=task&id_task=396

Сообщение отредактировано: c-ch - 6.04.2009 17:58

[volvo]

Я ничего с этим сервером не понимаю Была вот такая идея:

{$r-}
{$q-}
program Project1;
// uses windows;
const
  count = 100000;
type
  tevent = (ev_add, ev_check, ev_remove);
  trec = record
    ev: tevent;
    index: longint;
    X: longint;
  end;

  ev_array = array[1 .. 3 * count] of trec;
  arrtype = array[1 .. count] of longint;

var
  events: ev_array;


procedure quicksort(var a: ev_array; Lo,Hi: integer);
  function less(f, s: trec): boolean;
  begin
    less := (f.X < s.X) or ((f.X = s.X) and (f.ev < s.ev));
  end;
  function more(f, s: trec): boolean;
  begin
    more := (f.X > s.X) or ((f.X = s.X) and (f.ev > s.ev));
  end;
  procedure sort(l,r: integer);
  var
    i,j: integer;
    x,y: trec;
  begin
    i:=l; j:=r;  x := a[(r+l) div 2];
    repeat
      while less(a[i], x) do i:=i+1;
      while less(x, a[j]) do j:=j-1;
      if i<=j then
      begin
        if more(a[i], a[j]) 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;

// var tt: dword;
var
  f, fout: text;

  m, n, i, j: longint;
  cnt: arrtype;
  curr: longint;
  p, L, R: longint;

begin
  // tt := gettickcount;
  assign(f, 'input.txt'); reset(f);
  readln(f, n, m);
  j := 0;
  for i := 1 to n do begin
    readln(f, L, R);
    inc(j);
    events[j].ev := ev_add; events[j].index := -1; events[j].X := L;
    inc(j);
    events[j].ev := ev_remove; events[j].index := -1; events[j].X := R;
  end;

  for i := 1 to m do begin
    read(f, p);
    inc(j);
    events[j].ev := ev_check; events[j].index := i; events[j].X := p;
  end;
  quicksort(events, 1, j);
  close(f);

  curr := 0;
  for i := 1 to j do begin
    if events[i].ev = ev_add then inc(curr)
    else
      if events[i].ev = ev_check then cnt[events[i].index] := curr
      else dec(curr);
  end;

  assign(fout, 'output.txt'); rewrite(fout);
  for i := 1 to m do write(fout, cnt[i], ' ');
  close(fout);
  // writeln('time = ', gettickcount - tt);
end.

, 5 тестов отработало "влёт", на шестом с какого-то перепуга "неверный ответ", хотя что там может быть неверного? Может, ты найдешь ошибку в алгоритме?

[volvo]

Бррр... Да, сам виноват, посчитал, что в паре координат, образующих отрезок, всегда первой идет левая граница, а второй - правая. В условии этого не было указано, так что надо проверять, что меньше, а что - больше. С проверкой программа проходит все тесты, еще и с запасом...

c-ch, в алгоритме разобрался?

[c-ch]

да, спасибо :смайлик_с_пивом: