Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Delphi > Паскаль
Регистрация

Восстановить пароль
Повторная активизация e-mail


Донат для форума - использовать для поднятия настроения себе и модераторам

А ещё здесь можно купить рекламу за 25 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru

Ответ
 
Опции темы
Старый 02.06.2012, 19:55   #11
s-andriano
Профессионал
 
Аватар для s-andriano
 
Регистрация: 08.04.2012
Сообщений: 3,230
Репутация: 563
По умолчанию

Код:
     (x:293;y:271),(x:294;y:261),(x:283;y:261),(x:289;y:259),(x:296;y:260),(x:289;y:257),(x:297;y:260),(x:295;y:274),(x:289;y:272),(x:296;y:255),
     (x:282;y:257),(x:290;y:255),(x:291;y:255),(x:295;y:268),(x:295;y:269),(x:291;y:259),(x:293;y:266),(x:299;y:267),(x:299;y:259),(x:293;y:260),
     (x:230;y:305),(x:247;y:309),(x:235;y:318),(x:236;y:308),(x:237;y:313),(x:231;y:314),(x:231;y:321),(x:231;y:310),(x:248;y:312),(x:245;y:311),
     (x:243;y:321),(x:244;y:311),(x:233;y:311),(x:239;y:309),(x:246;y:310),(x:239;y:307),(x:247;y:310),(x:245;y:324),(x:239;y:322),(x:246;y:305),
     (x:232;y:307),(x:240;y:305),(x:241;y:305),(x:245;y:318),(x:245;y:319),(x:241;y:309),(x:243;y:316),(x:249;y:317),(x:249;y:309),(x:243;y:310),
     (x:330;y:305),(x:347;y:309),(x:335;y:318),(x:336;y:308),(x:337;y:313),(x:331;y:314),(x:331;y:321),(x:331;y:310),(x:348;y:312),(x:345;y:311),
     (x:343;y:321),(x:344;y:311),(x:333;y:311),(x:339;y:309),(x:346;y:310),(x:339;y:307),(x:347;y:310),(x:345;y:324),(x:339;y:322),(x:346;y:305),
     (x:332;y:307),(x:340;y:305),(x:341;y:305),(x:345;y:318),(x:345;y:319),(x:341;y:309),(x:343;y:316),(x:349;y:317),(x:349;y:309),(x:343;y:310),
     (x:380;y:355),(x:397;y:359),(x:385;y:368),(x:386;y:358),(x:387;y:363),(x:381;y:364),(x:381;y:371),(x:381;y:360),(x:398;y:362),(x:395;y:361),
     (x:393;y:371),(x:394;y:361),(x:383;y:361),(x:389;y:359),(x:396;y:360),(x:389;y:357));

var i : longint;
  t : text;
begin
  if k < MaxP then
    for i := 0 to k-1 do
      p[i] := pp[i]
  else begin
    for i := 0 to MaxP-1 do
      p[i] := pp[i];
    for i := MaxP to k-1 do begin
      p[i].x := random(20)+430;
      p[i].y := random(20)+405;
    end;
  end;
  assign(t,'t.t');
  rewrite(t);
  for i := MaxP to k-1 do
    writeln(t,'(x:',p[i].x:1:0,';y:',p[i].y:1:0,'),');
  close(t);
end;

var
  p: array[0..n0-1] of tPoint;
  n : longint;
var
  l: array[1..n0,1..n0] of tLine;
  used: array[1..n0,1..n0] of boolean;

procedure TinManCalc;
var
  i,j,u,v: integer;
  s: set of byte;
begin
  writeln('   TinMan');
  // calculating all the lines
  for i:=1 to n do
    for j:=1 to i-1 do l[i,j]:= NormalLineByPoints(p[i-1],p[j-1]);

  // looking for equal lines
  for i:=1 to n do
    for j:=1 to i-1 do
      if not used[i,j] then begin
        s:= [];
        for u:=i to n do
          for v:=1 to u-1 do
            if EqualLines(l[i,j],l[u,v]) then begin
              used[u,v]:= true;
              Include(s,u);
              Include(s,v)
            end;
        if s<>[i]+[j] then begin
          writeln('set:');
          for u:=1 to n do
            if u in s then with p[u-1] do writeln('#',u,':   x=',x:5:2,'  y=',y:5:2);
          writeln
        end
      end;
end;

function GetDist2(x0,y0, x1,y1, x2,y2 : tReal): tReal;
var
  a,b,c,x3,y3 : extended;
begin
  if x1 <> x2 then begin
    if y1 <> y2 then begin
      a := (y1-y2)/(x1-x2);
      b := (y2*x1 - y1*x2)/(x1-x2);
      c := -1/a;
      x3 := (y0 - x0*c - b)/(a - c);
      y3 := (y0*a + x0 - b*c)/(a - c);
    end else begin
      x3 := x0;
      y3 := y1;
    end; // if y1 <> y2
  end else begin
    if y1 <> y2 then begin
      x3 := x1;
      y3 := y0;
    end else begin
      x3 := x1;
      y3 := y1;
    end; // if y1 <> y2
  end; // if x1 <> x2
  GetDist2 := sqr(x3-x0) + sqr(y3-y0);
end;


procedure AndrianoCalc;
var i,j,k,MaxN,LocN : longint;
begin
  writeln('   andriano');
  MaxN := 2;
  for i := 0 to n-3 do
    for j := i+1 to n-2 do begin
      LocN := 2;
        for k := j+1 to n-1 do
          if GetDist2(p[i].x, p[i].y,p[j].x, p[j].y,p[k].x, p[k].y) < e then
            inc(LocN);
      if MaxN < LocN then MaxN := LocN;
    end;
  writeln('MaxN: ',MaxN);
  for i := 0 to n-3 do
    for j := i+1 to n-2 do begin
      LocN := 2;
        for k := j+1 to n-1 do
          if GetDist2(p[i].x, p[i].y,p[j].x, p[j].y,p[k].x, p[k].y) < e then
            inc(LocN);
      if MaxN = LocN then begin
        with p[i] do writeln('#',i,':   x=',x:5:2,'  y=',y:5:2);
        with p[j] do writeln('#',j,':   x=',x:5:2,'  y=',y:5:2);
        for k := j+1 to n-1 do
          if GetDist2(p[i].x, p[i].y,p[j].x, p[j].y,p[k].x, p[k].y) < e then
            with p[k] do writeln('#',k,':   x=',x:5:2,'  y=',y:5:2);
        writeln;
      end;
    end;
end;

var t0,t1,t2 : longint;
begin
  n := 8;
  n := 9;
  n := 40;
  n := 70;
  n := 256;
  GetData(n, p);
  t0 := GetTickCount;
  TinManCalc;
  t1 := GetTickCount;
  AndrianoCalc;
  t2 := GetTickCount;
  writeln('Elapsed time: TinMan = ',(t1-t0)/1000:2:1,' s, andriano = ',(t2-t1)/1000:2:1,' s');
  writeln('Need Memory:  TinMan = ',(Sizeof(l) + sizeof(used) + sizeof(p))/1024:2:1,' Kb, andriano = ',sizeof(p)/1024:2:1,' Kb');
  readln;
end.
s-andriano вне форума   Ответить с цитированием
Старый 04.06.2012, 13:30   #12
evg_m
Профессионал
 
Регистрация: 20.04.2008
Сообщений: 4,913
Репутация: 2242
По умолчанию

мой вариант без хранения промежуточных данных.
Код:
M: array[1..N] of record X,Y: integer; end; //массив точек

function OneLine(i,j,k: integer): boolean; //собственно проверка три точки на одной прямой
begin
//  (y1-Y2)*X3-(x1-X2)*Y3 =(x1*Y2-X2*Y1) прямая пр. через две точки(1,2) в третьей (3)
  result:=(M[i].Y-M[j].Y)*M[k].X - (M[i].X-M[j].Y)*M[k].Y = M[i].X*M[j].Y - M[j].X*M[i].Y;
// вроде не наврал 
end;
почему так? не требует перехода к вещественной арифметике => нет приближенных вычислений =>не нужен учет погрешностей.

Код:
for i:=1 to N-1 do 
  for j:=i+1 to N do // перебираем все пары точек
  begin
    r:=false; //проверяем есть ли далее точка на этой прямой (обеспечиваем единственность вывода прямой)
    for k:=j+1 to N do begin
       if OneLine(i,j,k) then 
       begin
          r:=true;
          break;
       end;
    end; 
    if not r then begin 
      //все точки данной прямой уже пройдены (дальше не встретим ни одной) можно выводить
      r3:=false; проверяем пригодность (>3 точек) (ничего не храним так что считаем еще разок!)
      for k:=1 to j do 
//        if k<>i and k<>j and OneLine(i,j,k) then //хорошая линия (>3) и все точки пройдены
        if (k<>i) and (k<>j) and OneLine(i,j,k) then //хорошая линия (>3) и все точки пройдены
        begin
          r3:=true;
          break;  
        end;
      for k:=1 to j do // перечисление точек прямой в порядке ввода
//        if k=i or k=j or OneLine(i,j,k) then //такую точку надо вывести
        if (k=i) or (k=j) or OneLine(i,j,k) then //такую точку надо вывести
          ..............................
    end; 
  end;
end;
код не проверял, писал в блокноте просто как иллюстрацию к комментариям.
__________________
программа — запись алгоритма на языке понятном транслятору

Последний раз редактировалось evg_m; 04.06.2012 в 13:43. Причина: знаю про скобки(приоритеты операций) но не могу прывыкнуть ставить автоматом.
evg_m вне форума   Ответить с цитированием
Старый 04.06.2012, 19:11   #13
s-andriano
Профессионал
 
Аватар для s-andriano
 
Регистрация: 08.04.2012
Сообщений: 3,230
Репутация: 563
По умолчанию

Цитата:
Сообщение от evg_m Посмотреть сообщение
почему так? не требует перехода к вещественной арифметике => нет приближенных вычислений =>не нужен учет погрешностей.
Как, оказывается, изящно можно сформулировать мысль:
"Дабы упростить себе жизнь, считаем координаты целыми, хотя из условия задачи это никак не следует".
s-andriano вне форума   Ответить с цитированием
Старый 04.06.2012, 20:11   #14
evg_m
Профессионал
 
Регистрация: 20.04.2008
Сообщений: 4,913
Репутация: 2242
По умолчанию

Цитата:
Как, оказывается, изящно можно сформулировать мысль:
"Дабы упростить себе жизнь, считаем координаты целыми, хотя из условия задачи это никак не следует".
Даже если так (координаты точек вещественные), то на общий алгоритм это никак не повлияет, все изменения коснуться только функции OneLine (проверка три точки на одной прямой). Не могу сразу сказать какие в точности это будут изменения (м.б. просто result:=abs(...)<=epsilon, а может более существенные, вычисление нормали и расстояния от точки до прямой, можем воспользоваться вашей функцией Getdist2).

P.S. Или другой подход к задаче.
Если не указано обратное, то исходные точки лежат в узлах координатной сетки => путем масштабирования всегда можно говорить о целочисленных координатах
А это всегда так, любое измерения проводится с заданной точностью.
Если не указано обратное, то точность расчетов должна быть абсолютной =>epsilon=0 => ....


а разве здесь не тоже
Цитата:
p: array[0..n0-1] of tPoint;
P.S. TPoint =record x,y: real; end; /// добрался, Увидел !

а вот замечание по алгоритму
1.
Код:
    r:=false; //проверяем есть ли далее точка на этой прямой (обеспечиваем единственность вывода прямой)
// было    for k:=j+1 to N do begin  //проверяем одну последнюю
    for k:=i+1to N do begin  // а надо (т.е. надо проверять что i j это две последних точки
2.
Код:
      r3:=false; проверяем пригодность (>3 точек) (ничего не храним так что считаем еще разок!)
// было      for k:=1 to j do 
   for k:=1to i do  // мы же знаем что дальше точек нет
Вообще цель была отказаться от этого пункта.
Цитата:
2. Сделать понятие линии однозначным. То есть, если две линии равны, то структуры, их определяющие, также должны быть равны. Предусмотреть функцию определения равенства линий.
Заменить на естественную упорядоченность линий по порядку точек
выбор линии по двум последним точкам
Цитата:
for i:=1 to N-1 do
for j:=i+1 to N do // перебираем все пары точек
Цитата:
r:=false; //проверяем есть ли далее точка на этой прямой (обеспечиваем единственность вывода прямой)
Цитата:
for k:=1 to j do // перечисление точек прямой в порядке ввода
__________________
программа — запись алгоритма на языке понятном транслятору

Последний раз редактировалось evg_m; 05.06.2012 в 09:54.
evg_m вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Даны координаты n точек на плоскости. Найти номера двух точек, расстояние между которыми наибольшее. Viwwna Паскаль 2 19.11.2011 06:33
множество точек с++ Hecpon Помощь студентам 6 21.12.2009 22:18
определить радиус и центр окружности, на кот. лежит наиб.число точек заданного на плоскости мн-ва точек) kcю Помощь студентам 0 17.11.2009 20:50
множество точек))) kcю Помощь студентам 0 11.11.2009 22:32


03:31.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.