Welcome, guest! Login / Register - Why register?
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&#40;True&#41;;
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

Your Name: Code Language: