Задача по Turbo Pascal

[Хыиуду]

Ну что мысли у кого-нибудь есть какие-нибудь?найти три точки, чтобы внутри треугольника с вершинами в этих точках содержалось бы наибольшее число заданных точек.

Мой предпредыдущий пост отвечает на этот вопрос. Если три любые точки - то ответ тривиален: три точки в плюс и минус бесконечности.

[assis2007]

Если честно ничего не понял из выш сказанного. Ты предложил искать принадлежность через сумму углов

[Хыиуду]

Объясняю.
Если точка О лежит внутри угла ABC, то луч BО проходит между лучами BА и ВС. В таком случае углы АВО и ОВС в сумме дают угол АВС. Если О лежит вне этого угла, тогда АВО+ОВС>АВС.

Поскольку нам известны координаты трех вершин треугольника, мы можем по теореме Пифагора найти длину каждой из трех сторон. После этого можем найти угол между двумя сторонами из теоремы косинусов: c^2=a^2+b^2-2ab*cos(alpha), где alpha - угол между сторонами a и b.

Итого, зная координаты точек А, В, С и О, мы определяем, лежит ли точка О внутри углов АВС, ВСА или САВ. Если лежит внутри хотя бы двух из них - она лежит внутри треугольника АВС. То же проверить для всех остальных точек.

И еще: что-то мне подсказывает, что наиболее вероятные кандидаты на должность искомых трех точек - те, в которых координаты либо максимальны, либо минимальны среди остальных точек

[assis2007]

А можно тоже самое в паскале теперь?

[Хыиуду]

Для того, чтобы перевести это на Паскаль, достаточно знать его синтаксис. Для того, чтобы знать синтаксис, достаточно прочитать учебник. Пробуйте. Если что-то будет не получаться - пишите

[assis2007]

Я тут набросал кое что естественно не компилируется
[syntax='Delphi']
Program treyg;
Uses Crt;
Const Max=50;
Var i,j,v,v1,n,a,b,c,way,u,z,NN,NM,L1,MMaxx:Integer;
X:array [1..Max] of Real;
WX,WY:array [1..6,1..Max] of Real;
Y:array [1..Max] of Real;
M:array [1..Max] of Integer;
ii:array [1..3] of Integer;
XX,YY:array [1..3] of Real;
Found,Pr:Boolean;
xa,ya,xb,yb,k1,k2,g1,g2,g3: Real;
xc,yc,xd,yd: array [1..2] of Real;
Procedure INput;
Begin
Repeat
WriteLn(' ‘Є®«мЄ® в®зҐЄ ‚л б®ЎЁа*ҐвҐбм ўўҐбвЁ (¤® 50) ? ');
Write(' ');
Readln(n);
If n<=0 then
Writeln(' ЌҐ¤®ЇгбвЁ¬®Ґ Є®«-ў®');
If n>Max then
Writeln(' €е Є®«-ў® б«ЁиЄ®¬ Ў®«м讥');
Until (N>0) and (N<=Max);
Writeln(' ‚ўҐ¤ЁвҐ Ёе Є®®а¤Ё**вл ');
For i:=1 to n do
Begin
Writeln(' ’®зЄ* A',i,':');
Write(' X',' = ');
Readln(X);
Write(' Y',' = ');
Readln(Y);

end
End;
Procedure DoingSum;
Procedure Lookfor;
Begin
Found:=False;
Pr:=FALSE;
xa:=X-X[a]; ya:=y-y[a];
xc:=X[c]-X[a]; yc:=y[c]-y[a];

xb:=X[c]-X; yb:=y[c]-y;
ii[1]:=a; ii[3]:=c;
ii[2]:=b;
For u:=1 to 3 do
For v:=(u+1) to 3 do
If (x[ii]=x[ii[v]])and(y[ii]=y[ii[v]]) then
Begin
PR:=true;
End;
For u:=1 to 3 do Begin
WX[u,z+1]:=X[ii];
WY[u,z+1]:=Y[ii];
End;
For u:=1 to z do Begin
NM:=0;
For v:=1 to 3 do
For v1:=1 to 3 do
If (WX[v1,z+1]=WX[v,u])and(WY[v1,z+1]=WY[v,u]) then
NM:=NM+1;
IF NM=3 then
PR:=true;
end;
If not Pr then Begin
If pr=true then Writeln('ЋиЁЎЄ* 2');
Way:=0;
g1:=(xa*xb+ya*yb)/(sqrt(sqr(xa)+sqr(ya))*sqrt(sqr(xb)+sqr(yb)));
g2:=(xb*xc+yb*yc)/(sqrt(sqr(xb)+sqr(yb))*sqrt(sqr(xc)+sqr(yc)));
g3:=(xa*xa+ya*yc)/(sqrt(sqr(xa)+sqr(ya))*sqrt(sqr(xc)+sqr(yc)));
If ABS(Round(g1*1000)/1000) = 1 then Begin
If ABS(Round(g2*1000)/1000)=1 then way:=way+1;
If ABS(Round(g3*1000)/1000)=1 then way:=way+2;
If (way=1) or (way=2) then
Found:=true;
If way=2 then
begin
WX[3,z+1]:=X[c];WX[2,z+1]:=X[d];
WY[2,z+1]:=Y
[d];WY[3,z+1]:=Y[c];
End;{If way=2}
End;{ЏҐаў®Ј® If-*}
End;{If not Pr}
End;{Procedure Lookfor}
Procedure Counting;
Begin
z:=z+1;
WX[5,z]:=WX[1,z];WX[6,z]:=WX[2,z];
WY[5,z]:=WY[1,z];WY[6,z]:=WX[2,z];
For j:=1 to n do Begin
NN:=0;
For i:=1 to 3 do
Begin
k1:=(WX[i+2,z]-Wx[i,z])*(Wy[i+1,z]-Wy[i,z])-(Wx[i+1,z]-Wx[i,z])*(Wy[i+2,z]-WY[i,z]);
k2:=(X[j]-Wx[i,z])*(Wy[i+1,z]-Wy[i,z])-(Wx[i+1,z]-Wx[i,z])*(y[j]-WY[i,z]);;
If k1*k2>0 then
NN:=NN+1;
End;
If NN=3 then
M[z]:= M[z] + 1;
End;
End;
Procedure Max;
Begin
MMaxx:= M[1]; {MMaxx-¬*ЄбЁ¬*«м*®Ґ Є-ў® в®зҐЄ ў Ї*а-¬Ґ,*®¬Ґа Є®в-Ј® L1}
L1:=1;
For I:=1 to z do
If Mmaxx<M then
Begin
Mmaxx:=M;
L1:=I;
End;
XX[1]:=WX[1,L1];XX[3]:=WX[3,L1];
XX[2]:=WX[2,L1];
YY[1]:=WY[1,L1];YY[3]:=WY[3,L1];
YY[2]:=WY[2,L1];
End;{Procedure Max}
Begin {DoingSum}
L1:=0;NN:=0;NM:=0;z:=0;
For a:=1 to (n-2) do
For b:=(a+1) to n do
For c:=(a+1) to n do
For d:=(c+1) to n do
Begin
Lookfor;
If Found then
Counting;
End;
If z>=1 then
Max;
End;{DoingSum}
Procedure OUTput;
Begin
If z=0 then Writeln('treyg *Ґв')
else Begin
Writeln('‚ҐаиЁ*л treygolnika , ᮤҐа¦*饣® ¬*ЄбЁ¬*«м*®Ґ Є®«-ў® в®зҐЄ:');
Writeln(' A( ',XX[1]:2:2,' , ',YY[1]:2:2,' )');
Writeln(' B( ',XX[2]:2:2,' , ',YY[2]:2:2,' )');
Writeln(' C( ',XX[3]:2:2,' , ',YY[3]:2:2,' )');

Writeln('„®Ї®«*ЁвҐ«м**п Ё*д®а¬*жЁп :');
Writeln({'…Ј® *®¬Ґа ',L1,}' ў *Ґ¬ ',Mmaxx,' в®зҐЄ, * ўбҐЈ® Ї*а*«-¬®ў ',z);
End;
ENd;
Begin
Clrscr;
Writeln(' Џа®Ја*¬¬* **室Ёв treyg, ᮤҐа¦*йЁ© ¬*ЄбЁ¬*«м*®Ґ Є®«-ў® §*¤***ле в®зҐЄ');
Writeln(' (ўҐаиЁ*л treyg -- ў §*¤***ле в®зЄ*е).');
Writeln;
INput;
DoingSum;
OUTput;
Readln;
end.
[/syntax]
не стал переписывать где выводятся сообщения
у меня вопрос нельзя ли прогу с параллелограммом переделать на треугольник?

[assis2007]

Мне нужна помощь в части вычисления треугольника с наибольшим числом точек внутри я делаю так: даны нам три точки А В С и некая Е и программа вычисляет входит Е в треугольник или нет через сумму площадь треугольника АВС равна площади трёх треугольников АВЕ АСЕ ВСЕ . Если она равна то входит .

[assis2007]

[syntax='Delphi']Program treygolnik;
Uses Crt;
Const Max=100;
Var i,j,v,v1,n,a,b,c,d,way,u,z,NN,NM,L1,MMaxx:Integer;
X:array [1..Max] of Real;
WX,WY:array [1..6,1..Max] of Real;
Y:array [1..Max] of Real;
M:array [1..Max] of Integer;
ii:array [1..3] of Integer;
XX,YY:array [1..3] of Real;
Found,Pr:Boolean;
xa,ya,xb,yb,k1,k2,g1,g2,g3: Real;
xc,yc,xd,yd: {array [1..2] of }Real;
Procedure INput;
Begin
Repeat
WriteLn(' kol-vo tochek ');
Write(' ');
Readln(n);
If n<=0 then
Writeln(' nedopystimoe chislo');
If n>Max then
Writeln(' slishkom mnogo');
Until (N>0) and (N<=Max);
Writeln(' vvedite koordinati ');
For i:=1 to n do
Begin
Writeln(' Tochka A',i,':');
Write(' X',' = ');
Readln(X);
Write(' Y',' = ');
Readln(Y);

end
End;
Procedure DoingSum;
Procedure Lookfor;
Begin
Found:=False;
Pr:=FALSE;
xa:=X-X[a]; ya:=y-y[a];
xc:=X[c]-X[a]; yc:=y[c]-y[a];

xb:=X[c]-X; yb:=y[c]-y;
ii[1]:=a; ii[3]:=c;
ii[2]:=b;
For u:=1 to 1{2} do
For v:=u to 2{3} do
If (x[ii]=x[ii[v]])and(y[ii]=y[ii[v]]) then
Begin
PR:=true;
End;
For u:=1 to 2{3} do Begin
WX[u,z+1]:=X[ii];
WY[u,z+1]:=Y[ii];
End;
For u:=1 to z do Begin
NM:=0;
For v:=1 to 2{3} do
For v1:=1 to 2{3} do
If (WX[v1,z+1]=WX[v,u])and(WY[v1,z+1]=WY[v,u]) then
NM:=NM+1;
IF NM=2{3} then
PR:=true;
end;
If not Pr then Begin
If pr=true then Writeln('Oshibka 2');
Way:=0;
g1:=(xa*xb+ya*yb)/(sqrt(sqr(xa)+sqr(ya))*sqrt(sqr(xb)+sqr(yb)));
g2:=(xc*xb+yc*yb)/(sqrt(sqr(xc)+sqr(yc))*sqrt(sqr(xb)+sqr(yb)));
g3:=(xc*xa+yc*ya)/(sqrt(sqr(xc)+sqr(yc))*sqrt(sqr(xa)+sqr(ya)));
If ABS(Round(g1*1000)/1000) = 1 then Begin
If ABS(Round(g2*1000)/1000)=1 then way:=way+1;
If ABS(Round(g3*1000)/1000)=1 then way:=way+2;
If (way=1) or (way=2) then
Found:=true;
If way=2 then
begin
WX[2{3},z+1]:=X[c];WX[1{2},z+1]:=X[d];
WY[1{2},z+1]:=Y
[d];WY[2{3},z+1]:=Y[c];
End;{If way=2}
End;{ЏҐаў®Ј® If-*}
end;
End;
Procedure Counting;
Begin
z:=z+1;
WX[2,z]:=WX[1,z];WX[3,z]:=WX[2,z];
WY[2,z]:=WY[1,z];WY[3,z]:=WX[2,z];
For j:=1 to n do Begin
NN:=0;
For i:=1 to 2{3} do
Begin
k1:=(WX[i+2,z]-Wx[i,z])*(Wy[i+1,z]-Wy[i,z])-(Wx[i+1,z]-Wx[i,z])*(Wy[i+2,z]-WY[i,z]);
k2:=(X[j]-Wx[i,z])*(Wy[i+1,z]-Wy[i,z])-(Wx[i+1,z]-Wx[i,z])*(y[j]-WY[i,z]);;
If k1*k2>0 then
NN:=NN+1;
End;
If NN=2{3} then
M[z]:= M[z] + 1;
End;
End;
Procedure Max;
Begin
MMaxx:= M[1];
L1:=1;
For I:=1 to z do
If Mmaxx<M then
Begin
Mmaxx:=M;
L1:=I;
End;
XX[1]:=WX[1,L1];XX[3]:=WX[3,L1];
XX[2]:=WX[2,L1];
YY[1]:=WY[1,L1];YY[3]:=WY[3,L1];
YY[2]:=WY[2,L1];
End;{Procedure Max}
Begin {DoingSum}
L1:=0;NN:=0;NM:=0;z:=0;
For a:=1 to (n-1) do
For b:=a to n do
For c:=a to n do

Begin
Lookfor;
If Found then
Counting;
End;
If z>=1 then
Max;
End;{DoingSum}
Procedure OUTput;
Begin
If z=0 then Writeln('treyg net ')
else Begin
Writeln('vershini treyg:');
Writeln(' A( ',XX[1]:2:2,' , ',YY[1]:2:2,' )');
Writeln(' B( ',XX[2]:2:2,' , ',YY[2]:2:2,' )');
Writeln(' C( ',XX[3]:2:2,' , ',YY[3]:2:2,' )');

End;
ENd;
Begin
Clrscr;
Writeln(' proga nahodit treyg');
Writeln(' (vershini treyg -- v zadanih tochkah).');
Writeln;
INput;
DoingSum;
OUTput;
Readln;
end.
[/syntax]
Вот компилируется но не находит что надо. Ввожу координаты но выводит нет решений

[assis2007]

Люди выручайте плиз!!!!

[assis2007]

Я написал но возникла проблема если ввожу координаты (1;1) (2;2) (3;3) то выводит нельзя построить а если ввожу (-0.5;-0.5) (-1;-1) (0;0) (0.5;0.5) (1;1) то он находит треугольник

Код: Выделить всё

program TREYGOLNIK;


const
B=0.001;

var
n,i,C,j,A,m,k:integer;
X,Y: array [1..100] of real;
s: array [1..3] of real;
W: array [1..4] of real;
TR: array [1..3,1..2] of real;
pr: boolean;
L: real;

function dl(a,b,c,d:real):real;
 begin
  dl:=sqrt((a-b)*(a-b)+(c-d)*(c-d));
 end;
function plo(a,b,c:real):real;
 begin
  plo:=sqrt(((a+b+c)/2)*((a+b-c)/2)*((a+c-b)/2)*((b+c-a)/2));
 end;
function plot(a,b,c:real):real;
 begin
  plot:=sqrt(((a+b+c)/2)*((a+b-c)/2)*((a+c-b)/2)*((b+c-a)/2));
 end;

begin
 writeln ('Нахождение треугольника с наибольшим числом заданных точек');
 repeat
  write ('Введите число точек = ');
  readln (n);
  if (n<3) or (n>100) then
   writeln ('Неверное число');
 until (n>=3) and (n<=100);
 writeln ('Введите координаты точки');
 for i:=1 to n do
  begin
   write ('Введите абсциссу ',i,' точки = ');
   readln (X[i]);
   write ('Введите ординату ',i,' точки = ');
   readln (Y[i]);
  end;
 pr:=false;
 C:=0;
 for i:=1 to (n-2) do
  for j:=i+1 to (n-1) do

    for k:=j+1 to n do
     begin
      s[1]:=dl(X[i],X[j],Y[i],Y[j]);
      s[2]:=dl(X[i],X[k],Y[i],Y[k]);
      s[3]:=dl(X[j],X[k],Y[j],Y[k]);
          if (s[1]<s[2]+s[3]) and (s[2]<s[1]+s[3]) and (s[3]<s[1]+s[2]) then
           begin

            A:=0;
            for m:=1 to n do
             begin
              W[1]:=plo(dl(X[m],X[i],Y[m],Y[i]),dl(X[m],X[k],Y[m],Y[k]),dl(X[i],X[k],Y[i],Y[k]));
              W[2]:=plo(dl(X[m],X[i],Y[m],Y[i]),dl(X[m],X[j],Y[m],Y[j]),dl(X[i],X[j],Y[i],Y[j]));
              W[3]:=plo(dl(X[m],X[j],Y[m],Y[j]),dl(X[m],X[k],Y[m],Y[k]),dl(X[j],X[k],Y[j],Y[k]));
              W[4]:=plot(dl(X[i],X[j],Y[i],Y[j]),dl(X[j],X[k],Y[j],Y[k]),dl(X[i],X[k],Y[i],Y[k]));
              L:=W[1]+W[2]+W[3]-W[4];
              if abs(L)<=B then
               A:=A+1;
             end;
             if A>=C then
              begin
               C:=A;
              TR[1,1]:=X[i];
              TR[1,2]:=Y[i];
              TR[2,1]:=X[j];
              TR[2,2]:=Y[j];
              TR[3,1]:=X[k];
              TR[3,2]:=Y[k];


               pr:=true;
              end;
             end;
           end;
 if pr then
  begin
   writeln ('Вершины искомого треугольника:');
   for i:=1 to 3 do
    writeln ('(',TR[i,1],',',TR[i,2],')');
  end
 else
  writeln ('Построить треугольник нельзя');
end.