Psst.. new poll here.
Psst.. new forums here.
Microsoft is blocking us again (TY IP Reputation!) so just use oauth login instead. :)
Paste
Pasted as Plain Text by 1 ( 12 years ago )
unit Unit91;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls,xpman, StdCtrls, TeEngine, Series, ExtCtrls, TeeProcs,
Chart,Clipbrd,math;
type
TForm1 = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
TabSheet4: TTabSheet;
Label3: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit6: TEdit;
Edit7: TEdit;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Image1: TImage;
Chart1: TChart;
Series1: TLineSeries;
Label9: TLabel;
Label10: TLabel;
Edit8: TEdit;
Edit9: TEdit;
Image2: TImage;
Label11: TLabel;
Button5: TButton;
Button7: TButton;
Label12: TLabel;
Label13: TLabel;
Label4: TLabel;
Label2: TLabel;
Label14: TLabel;
Label1: TLabel;
Label15: TLabel;
Label16: TLabel;
Label17: TLabel;
Edit4: TEdit;
Edit5: TEdit;
Edit10: TEdit;
Edit11: TEdit;
Edit12: TEdit;
Edit13: TEdit;
Label18: TLabel;
Label19: TLabel;
Label20: TLabel;
Label21: TLabel;
Label22: TLabel;
Label23: TLabel;
Label24: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button5Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
mas=array[1..4] of integer;
var
Form1: TForm1;
xn,xk,x,y,h,yomax,yomin: extended;
m,i:integer;
cx,cy:mas;
implementation
{$R *.dfm}
function ret:boolean; // проверка , не повторяются ли координаты
var i,j:integer;
begin
ret:=true;
for i:=1 to 3 do
for j:=i+1 to 4 do
begin
if (cx[i]=cx[j]) and (cy[i]=cy[j]) then begin
ret:=false;
exit;
end;
end;
end;
function trueness(c,d,e,f:integer):boolean; // проверка правильности построения четырёхугольника
var ka,kb,ba,bb,x:extended;
begin
if (cx[d]-cx[c])=0 then ka:=0
else ka:=(cy[d]-cy[c])/(cx[d]-cx[c]);
if (cx[f]-cx[e])=0 then kb:=0
else kb:=(cy[f]-cy[e])/(cx[f]-cx[e]);
if ka=kb then begin trueness:=true; exit; end;
ba:=cy[c]-ka*cy[c];
bb:=cy[e]-kb*cx[e];
x:=(bb-ba)/(ka-kb);
if (x>min(cx[c],cx[d])) and (x<max(cx[c],cx[d])) and (x>min(cx[e],cx[f])) and (x<max(cx[e],cx[f]))
then trueness:=false else trueness:=true;
end;
function razn(a:mas):extended; // для масштабирования
var max,min:extended;
i:integer;
begin
max:=a[1];min:=a[1];
for i:=2 to 4 do begin
if a[i]>max then max:=a[i];
if a[i]<min then min:=a[i];
end;
razn:=max-min;
end;
function check(a,b:mas):boolean; // проверка на выпуклость
var c,d:extended;
begin
check:=false;
c:=(a[1]-a[2])*(b[4]-b[2])-(a[4]-a[2])*(b[1]-b[2]);
d:=(a[4]-a[2])*(b[3]-b[2])-(a[3]-a[2])*(b[4]-b[2]);
if ((c>0) and (d>0)) or ((c<0) and (d<0)) then begin
c:=(a[2]-a[1])*(b[3]-b[1])-(a[3]-a[1])*(b[2]-b[1]);
d:=(a[3]-a[1])*(b[4]-b[1])-(a[4]-a[1])*(b[3]-b[1]);
if ((c>0) and (d>0)) or ((c<0) and (d<0)) then check:=true;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var xmax, ymax, yo : integer;
hx, hy : extended;
begin
image1.picture:=nil;
xn:=strtofloat(edit1.text);
xk:=strtofloat(edit2.text);
m:=strtoint(edit3.text);
yomin:=strtofloat(edit6.text);
yomax:=strtofloat(edit7.text);
with Image1.Canvas do begin
Pen.Color:=clBlack;
Brush.Color:=clGreen;
xmax:=Image1.Width;
ymax:=Image1.Height;
yo:=ymax div 2;
moveto(0,yo); lineto (xmax,yo);
moveto (0,0); lineto (0,ymax);
Pen.Color:=clRed;
Pen.Width:=2;
hx:=(xk-xn)/xmax;
hy:=(yomax-yomin)/ymax;
h:=(xk-xn)/(m-1);
x:=xn;
y:=arctan(x);
moveto(round(x/hx),round(yo-y/hy));
for i:=1 to m do begin
x:=x+h;
y:=arctan(x);
lineto(round(x/hx),round(yo-y/hy));
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ClipBoard.Assign(Image1.Picture);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
xn:=StrToFloat(Edit1.Text);
xk:=StrToFloat(Edit2.Text);
m:=StrToInt(Edit3.Text);
yomin:=StrToFloat(Edit6.Text);
yomax:=StrToFloat(Edit7.Text);
with Chart1 do begin
LeftAxis.Automatic:=False;
LeftAxis.Minimum:=yomin;
LeftAxis.Maximum:=yomax;
BottomAxis.Automatic:=False;
BottomAxis.Minimum:=xn;
BottomAxis.Maximum:=xk;
SeriesList[0].Clear;
h:=(xk-xn)/(m-1); x:=xn;
for i:=1 to m do begin
y:=arctan(x);
SeriesList[0].AddXY(x,y);
x:=x+h;
end;
end;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
Chart1.CopyToClipboardMetafile(True);
end;
procedure TForm1.Button7Click(Sender: TObject); //построить
var a:integer;
xmax,ymax,hy,hx:extended;
begin
Image2.Picture:=nil;
try
cx[1]:=strtoint(edit8.text);
cy[1]:=strtoint(edit9.text);
cx[2]:=strtoint(edit4.text);
cy[2]:=strtoint(edit5.text);
cx[3]:=strtoint(edit10.text);
cy[3]:=strtoint(edit11.text);
cx[4]:=strtoint(edit12.text);
cy[4]:=strtoint(edit13.text);
xmax:=Image2.Width;
ymax:=Image2.Height;
hy:=razn(cy)/ymax;
hx:=razn(cx)/xmax;
with Image2.Canvas do begin
pen.Color:=clRed;
pen.width:=5;
for a:=1 to 4 do begin
if a=1 then moveto(round(cx[a]/hx),round(cy[a]/hy))
else if a=4 then begin
lineto(round(cx[a]/hx),round(cy[a]/hy));
lineto(round(cx[1]/hy),round(cy[1]/hy));
end else lineto(round(cx[a]/hx),round(cy[a]/hy));
end;
end;
if trueness(1,2,3,4) and trueness(1,4,2,3) and ret then begin
button5.Show;
if check(cx,cy) then begin
label12.Font.Color:=clGreen;
label12.caption:='Этот четырёхугольник выпуклый!'
end else begin
label12.Font.Color:=clBlue;
label12.Caption:='Этот четырёхугольник невыпуклый!';
end;
end else begin
label12.Font.Color:=clRed;
label12.caption:='Чётырёхугольник построен неправильно!';
end;
except
on EConvertError do begin
ShowMessage('В ячейке отсутствует значение, либо число введено не правильно');
Exit; end;
else begin ShowMessage('Ошибка! Проверьте ваши координаты!');
Exit; end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Button5.Hide;
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
ClipBoard.Assign(Image2.Picture);
end;
end.
Revise this Paste