Тема: показати зображення
Добрий вечір, шановні експерти! Перейшов з делфі на лазарус. Все подобається. В лазарусі програмувати так само як і на делфі. Так от моє питання:
Мені треба заповнити smallim1 шістьма фігурками з тим масштабом, як у мене. допоможіть, будь-ласка.
Ось код програми
фрагмент uMain
unit uMain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, FileUtil, Forms, Controls, Graphics, Dialogs, Menus,
ExtCtrls, ComCtrls, StdCtrls, computations;
type
TRec = record
ndet,ang:integer;
Xa1,Ya1,Xa2,Ya2,Xq,Yq:real;
end;
{ TfMain }
TfMain = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
OpenDialog1: TOpenDialog;
RadioButton1: TRadioButton;
RadioButton2: TRadioButton;
SmallIm1: TImage;
MainIm1: TImage;
MainMenu1: TMainMenu;
MenuItem1: TMenuItem;
MenuItem3: TMenuItem;
MenuItem2: TMenuItem;
MenuItem4: TMenuItem;
MenuItem5: TMenuItem;
MenuItem6: TMenuItem;
MenuItem7: TMenuItem;
PageControl1: TPageControl;
ScrollBox1: TScrollBox;
TabSheet1: TTabSheet;
procedure FormCreate(Sender: TObject);
procedure OpenFileClick(Sender: TObject);
procedure readresho;
procedure readreshp;
procedure showresho;
procedure showreshp;
procedure openf_dgt;
private
{ private declarations }
public
{ public declarations }
namedet:string[100];
kilkpointdet_r,ndetP,ang:array[1..40] of integer;
dets_r,det_P,uklO,uklP:array[1..40] of figure;
end;
var
fMain: TfMain;
f:text;
str,fname,fname_ukl0,fname_ukl1,fname_dgt:string[100];
mgod,kilkdet,clickadd,clickdel,xp_e,yp_e,KilkuklO,KilkuklP,NumResh:integer;
mashim2,mashim1,xe,ye,dlmat,shmat,xp,yp,mashim4O,dlUkl_max,shUkl_max,
mashim4P,mashim3,dlright,dlleft,shup,shdown,pv,snet,smat:real;
dldet,shdet,sdet,XcO,YcO,dlO,shO,XcP,YcP,dlP,shP:array[1..40] of real;
admode,delmode,detmode,reshmode,fl:boolean;
shmUklO,shmUklP: array[1..100] of TRec;
implementation
{$R *.lfm}
{ TfMain }
{=========================================================}
procedure TfMain.OpenFileClick(Sender: TObject);//відкрити файл і запам’ятати дані
//Стандартна процедура, де параметр Sender передається як об’єкт, який ініціалізує процедуру.
var I ,L:integer;
//Блок описання змінних.
//Змінна i має цілочислений тип і використовується як змінна циклу.
Begin //початок процедури
Pagecontrol1.ActivePage:=tabsheet1; //встановлюємо активну сторінку
SmallIm1.Picture:=nil;//очищаємо малюнок з мініатюрними зображенями2
SmallIm1.Height:=2000;//встановлюємо розмір малюнку з мініатюрними зображенями2
OpenDialog1.InitialDir:=ExtractFilePath(Application.Exename);
if OpenDialog1.Execute then begin //якщо діалог виконується
fname:=opendialog1.FileName; //зберегти ім’я, вибране в діалозі у змінну
str:=ExtractFileName(fname);
l:=length(str);
for i:=1 to l do begin
if (str[i]='_') and (str[i+1]='0') then begin
fname_ukl0:=ExtractFilePath(Application.Exename)+'ukl\'+str; readreshO;
pagecontrol1.ActivePage.Caption:=fname_ukl0; // виводимо «ім’я моделі» в назву активної сторінки
end;
if (str[i]='_') and (str[i+1]='1') then begin
fname_ukl1:=ExtractFilePath(Application.Exename)+'ukl\'+str; readreshP;
pagecontrol1.ActivePage.Caption:=fname_ukl1; // виводимо «ім’я моделі» в назву активної сторінки
reshmode:=true; showreshp;
end;
if str[i]='_' then begin
delete(str,i,6); fname_dgt:=ExtractFilePath(Application.Exename)+'dgt\'+str+'.dgt';
end;
end;
end; //кінець якщо діалог виконується
PageControl1.Show;
openf_dgt;
fMain.Caption:=fname_dgt;
end;
{=========================================================}
procedure TfMain.openf_dgt;
var i,j:integer;
maxX,maxY,minX,minY:array[1..40] of real;
begin
assignfile(f,fname_dgt); // зв’язуємо віртуальний файл з ім’ям у змінній
reset(f); //відкриваємо файл для читання з переводом курсору на початок файлу
readln(f); //читаємо з файлу першу стрinttostr(shmuklP[2].Xa1)ічку в змінну «ім’я моделі»
readln(f,kilkdet); //читаємо з файлу другу стрічку в змінну «кількість деталей»
for i:=1 to kilkdet do readln(f,namedet[i]); //в циклі від 1 до кількості
//деталей послідовно зчитувати з файлу стрічки у масив «імена деталей»
for i:=1 to kilkdet do readln(f,kilkpointdet_r[i]);//в циклі від 1 до кількості
//деталей послідовно зчитувати з файлу стрічки у масив «кількість точок деталей»
for i:=1 to kilkdet do //в циклі від 1 до кількості деталей
for j:=0 to kilkpointdet_r[i]-1 do begin//в циклі від 0 до кількості точок
//деталей – 1 послідовно зчитувати з файлу стрічки у масив «координати деталей»
readln(f,dets_r[i][j].x,dets_r[i][j].y);
det_P[i,j].x:=-dets_r[i,j].x;
det_P[i,j].y:=-dets_r[i,j].y;
end;
closefile(f); //закриваємо файл
for i:=1 to kilkdet do begin
maxY[i]:=min_maxY(dets_r[i],kilkpointdet_r[i],1);//в циклі від 1 до кількості деталей
//розраховуємо мінімальне і максимальне значення по х і у відповідно
maxX[i]:=min_maxX(dets_r[i],kilkpointdet_r[i],1);
minX[i]:=min_maxX(dets_r[i],kilkpointdet_r[i],-1);
minY[i]:=min_maxY(dets_r[i],kilkpointdet_r[i],-1);
//розраховуємо довжину і ширину деталі
dldet[i]:=maxX[i]-minX[i];
shdet[i]:=maxY[i]-minY[i];
end; //кінець циклу по кількості деталей
end;
{=========================================================}
procedure TfMain.FormCreate(Sender: TObject);
begin
PageControl1.Hide;
reshmode:=false;
end;
{=========================================================}
procedure TfMain.readresho;
var i:integer;
begin
assignfile(f,fname_ukl0); // зв’язуємо віртуальний файл з ім’ям у змінній
Reset(f); //відкриваємо файл для читання з переводом курсору на початок файлу
Readln(f,KilkuklO); //читаємо з файлу перше слово в змінну «кількість укладок»
for i:=1 to KilkuklO do
with shmUklO[i] do begin
Read(f,ndet); //читаємо з файлу перше слово в змінну «номер деталі»
read(f,xa1,ya1,xa2,ya2);//читаємо з файлу решту слів стрічки в змінні «координати деталей»
readln(f,ang); //читаємо з файлу останнє слово в змінну «кут деталі»
end;
CloseFile(f); //закриваємо файл
ramka(1,KilkuklO);
end;
{=========================================================}
procedure TfMain.readreshp;
var i:integer;
begin
assignfile(f,fname_ukl1); // зв’язуємо віртуальний файл з ім’ям у змінній
Reset(f); //відкриваємо файл для читання з переводом курсору на початок файлу
Readln(f,KilkuklP); //читаємо з файлу перше слово в змінну «кількість укладок»
for i:=1 to KilkuklP do
with shmUklP[i] do begin
Read(f,ndet); //читаємо з файлу перше слово в змінну «номер деталі»
read(f,xa1,ya1,xa2,ya2,xq,yq);//читаємо з файлу решту слів стрічки в змінні «координати деталей»
readln(f,ang); //читаємо з файлу останнє слово в змінну «кут деталі»
end;
CloseFile(f); //закриваємо файл
ramka(1,KilkuklP);
end;
{=========================================================}
procedure TfMain.showresho;
var XminO,YminO,XmaxO,YmaxO:array[1..6] of real;
alpha,beta,mashy:real;
i,j:integer;
det:figure;
begin
for j:=1 to KilkuklO do begin
with shmUklO[j] do begin
for i:=1 to 4 do begin
case i of
1:begin alpha:=0; beta:=0; end;
2:begin alpha:=xa1; beta:=ya1; end;
3:begin alpha:=xa2; beta:=ya2; end;
4:begin alpha:=xa1+xa2; beta:=ya1+ya2; end;
end;
XminO[i]:=-dldet[ndet]/2+alpha;
XmaxO[i]:=dldet[ndet]/2+alpha;
YminO[i]:=-shdet[ndet]/2+beta;
YmaxO[i]:=shdet[ndet]/2+beta;
end;
dlO[j]:=maxR(4, XmaxO)-minR(4, XminO);
XcO[j]:=(maxR(4, XmaxO)+minR(4, XminO))/2;
shO[j]:=maxR(4, YmaxO)-minR(4, YminO);
YcO[j]:=(maxR(4, YmaxO)+minR(4, YminO))/2;
end;
end; if dlO[3]<>0 then begin
dlUkl_max:=maxR(KilkuklO, dlO);
shUkl_max:=maxR(KilkuklO, shO);
end;
edit1.Text:=FormatFloat('0.00',shUkl_max);
edit2.Text:=FormatFloat('0.00',dlUkl_max);
mashim4O:=60/dlUkl_max;
mashy:=60/shUkl_max;
if mashim4O> mashy then mashim4O:=mashy;
ramka(4,KilkuklO);
for i:=1 to KilkuklO do
with shmUklO[i] do begin
graphimsmall(1,kilkpointdet_r[ndet],dets_r[ndet],mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=dets_r[ndet,j].x+Xa1;
det[j].y:=dets_r[ndet,j].y+Ya1;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=dets_r[ndet,j].x+Xa2;
det[j].y:=dets_r[ndet,j].y+Ya2;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=dets_r[ndet,j].x+Xa1+Xa2;
det[j].y:=dets_r[ndet,j].y+Ya1+Ya2;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4O,XcO[i],YcO[i],37,75*(2*i-1)/2);
end;
end;
{======================================================}
procedure TfMain.showreshp;
var XminP,YminP,XmaxP,YmaxP:array[1..6] of real;
alpha,beta,mashY:real;
i,j:integer;
det:figure;
begin
for j:=1 to KilkuklP do begin
with shmUklP[j] do begin
for i:=1 to 6 do begin
if i=1 then begin alpha:=0; beta:=0; end;
if i=2 then begin alpha:=xa1; beta:=ya1; end;
if i=3 then begin alpha:=xq; beta:=yq; end;
if i=4 then begin alpha:=xa1+xq; beta:=ya1+yq; end;
if i=5 then begin alpha:=xa2; beta:=ya2; end;
if i=6 then begin alpha:=xa1+xa2; beta:=ya1+ya2; end;
XminP[i]:=-dldet[ndet]/2+alpha;
XmaxP[i]:=dldet[ndet]/2+alpha;
YminP[i]:=-shdet[ndet]/2+beta;
YmaxP[i]:=shdet[ndet]/2+beta;
end;
dlP[j]:=maxR(6, XmaxP)-minR(6, XminP);
XcP[j]:=(maxR(6, XmaxP)+minR(6, XminP))/2;
shP[j]:=maxR(6, YmaxP)-minR(6, YminP);
YcP[j]:=(maxR(6, YmaxP)+minR(6, YminP))/2;
end;
end;
dlUkl_max:=maxR(KilkuklP, dlP);
shUkl_max:=maxR(KilkuklP, shP);
for j:=1 to KilkuklP do
edit1.Text:=edit1.Text+FormatFloat('0.00',XcP[j]);
for j:=1 to KilkuklP do
edit2.Text:=edit2.Text+FormatFloat('0.00',YcP[j]);
mashim4P:=dlUkl_max/60;
mashy:=shUkl_max/80;
if mashim4P>mashy then mashim4P:=mashy ELSE MASHIM4P:=0.07;
for i:=1 to KilkuklP do
with shmUklP[i] do begin
graphimsmall(1,kilkpointdet_r[ndet],dets_r[ndet],mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=dets_r[ndet,j].x+Xa1;
det[j].y:=dets_r[ndet,j].y+Ya1;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=det_P[ndet,j].x+Xq;
det[j].y:=det_P[ndet,j].y+Yq;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=det_P[ndet,j].x+Xq+Xa1;
det[j].y:=det_P[ndet,j].y+Yq+Ya1;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=dets_r[ndet,j].x+Xa2;
det[j].y:=dets_r[ndet,j].y+Ya2;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
for j:=0 to kilkpointdet_r[ndet]-1 do begin
det[j].x:=dets_r[ndet,j].x+Xa1+Xa2;
det[j].y:=dets_r[ndet,j].y+Ya1+Ya2;
end;
graphimsmall(1,kilkpointdet_r[ndet],det,mashim4P,XcP[i],YcP[i],37,75*(2*i-1)/2);
end;
end;
{======================================================}
end.фрагмент
unit computations;
interface
uses SysUtils, Forms, Classes, Buttons, Graphics, StdCtrls, ExtCtrls;
type
point = record
x : real;
y : real;
end;
figure = array[0..100] of point;
function minR(n:integer;a :array of real):real;
function maxR(n:integer;a :array of real):real;
function elminx(n:integer;a :figure;var p:integer):real;
function elminy(n:integer;a :figure;var p:integer):real;
function elmaxx(n:integer;a :figure;var p:integer):real;
function elmaxy(n:integer;a :figure;var p:integer):real;
function min_maxX(a :figure; n,p:integer):real;
function min_maxY(a :figure; n,p:integer):real;
procedure sort(n:integer;a :figure; km:integer; var b :figure);
procedure ramka(im,kilk:integer);
procedure graphimsmall(im,n:integer;d:array of point;mxy,xcf,ycf,xce,yce:real);
procedure graphim1(n:integer;d:array of point;mxy,xce,yce,xp,yp:real;p,q:integer);
procedure obhod(n:integer;a :figure;var b :figure);
procedure godog(nn,nr:integer;fn,fr:figure;var m:integer;var gxy:figure);
procedure obolonka(n:integer;a :figure; var m:integer;var b:figure);
procedure prg_info(flg:byte);
implementation
uses uMain;
{============================================================}
function minR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
zam:real;
begin
zam:=a[1];
for i:=2 to n do
if a[i]<zam then zam:=a[i];
minR:=zam;
end;
{=========================================================}
function maxR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
zam:real;
begin
zam:=a[1];
for i:=2 to n do
if a[i]>zam then zam:=a[i];
maxR:=zam;
end;
{============================================================}
procedure obolonka(n:integer;a :figure;var m:integer;var b:figure);
var i,p,nr:integer;
ax,ay,bx,by,d:real;
flag:boolean;
begin
nr:=n;//зберігаємо кількість точок
repeat
flag:=true; //всі точки включаємо
i:=0; p:=0;
b[p].x:=a[i].x; b[p].y:=a[i].y; //початкова точка апроксимованої фігури
repeat
ax:=a[i+1].x-a[i].x; ay:=a[i+1].y-a[i].y; //координати вектора а
bx:=a[i+2].x-a[i].x; by:=a[i+2].y-a[i].y; //координати вектора b
d:=ax*by-ay*bx; //знак обходу
if d>0 then begin
inc(p);
b[p].x:=a[i+1].x; b[p].y:=a[i+1].y;
inc(p);
b[p].x:=a[i+2].x; b[p].y:=a[i+2].y;
end
else begin
flag:=false; //цю точку не включаємо
inc(p);
b[p].x:=a[i+2].x; b[p].y:=a[i+2].y;
end;
i:=i+2; //пересуваємося на кінець вектора b
if i+2>nr-2 then begin
inc(p);
b[p].x:=a[i+1].x; b[p].y:=a[i+1].y;
break;
end;
until false;
nr:=p+1;
for i:=0 to nr-1 do begin
a[i].x:=b[i].x; a[i].y:=b[i].y;
end;
until flag;
m:=nr;
b[m-1].x:=b[0].x; b[m-1].y:=b[0].y;
end;
{=========================================================}
function elminx(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //мінімальною х координатою та повертаємо її порядковий номер
zam:real;
begin
zam:=a[0].x; p:=0;
for i:=1 to n-1 do
if a[i].x<zam then begin
zam:=a[i].x; p:=i;
end;
elminx:=zam;
end;
{=========================================================}
function elminy(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //мінімальною у координатою та повертаємо її порядковий номер
zam:real;
begin
zam:=a[0].y; p:=0;
for i:=1 to n-1 do
if a[i].y<zam then begin
zam:=a[i].y; p:=i;
end;
elminy:=zam;
end;
{=========================================================}
function elmaxx(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //максимальною х координатою та фіксуємо її порядковий номер
zam:real;
begin
zam:=a[0].x; p:=0;
for i:=1 to n-1 do
if a[i].x>zam then begin
zam:=a[i].x; p:=i;
end;
elmaxx:=zam;
end;
{=========================================================}
function elmaxy(n:integer;a :figure;var p:integer):real; //знаходимо точку з
var i:integer; //максимальною у координатою та фіксуємо її порядковий номер
zam:real;
begin
zam:=a[0].y; p:=0;
for i:=1 to n-1 do
if a[i].y>zam then begin
zam:=a[i].y; p:=i;
end;
elmaxy:=zam;
end;
{=========================================================}
function min_maxX(a :figure; n,p:integer):real; //функція повертає точку з
var zam:real; //максимальною або мінімальною х координатою в
i:integer; //залежності від параметра р: 1 – максимальне; -1 – мінімальне.
begin
zam:=a[1].x;
for i:=2 to n do
if a[i].x*p>zam*p then
zam:=a[i].x;
min_maxX:=zam;
end;
{=========================================================}
function min_maxY(a :figure; n,p:integer):real; //функція повертає точку з
var zam:real; //максимальною або мінімальною х координатою в
i:integer; //залежності від параметра р: 1 – максимальне; -1 – мінімальне.
begin
zam:=a[1].y;
for i:=2 to n do
if a[i].y*p>zam*p then
zam:=a[i].y;
min_maxY:=zam;
end;
{=========================================================}
procedure sort(n:integer;a :figure; km:integer; var b :figure); //сортирує точки
var i:integer; //деталі за номером точки з максимальною або
begin //мінімальною х чи у координатою
if km=0 then begin
b:=a;
exit;
end;
for i:=0 to n-1 do begin
if km+i>n then break;
b[i].x:=a[km+i].x;
b[i].y:=a[km+i].y;
end;
for i:=1 to km do begin
b[i+n-km-1].x:=a[i].x;
b[i+n-km-1].y:=a[i].y;
end;
end;
{=========================================================}
procedure ramka(im,kilk:integer); // малює рамку зображення деталі на малюнку зліва
var i:integer;
image:TComponent;
begin
image := fMain.FindComponent('SmallIm' + IntToStr(im));
with TImage(image).Canvas do begin
Brush.Color:=clwhite;
Rectangle(0,0,fMain.width,fMain.height);
pen.Color:=clblack;
for i:=1 to kilk do begin
moveto(5,5+(i-1)*95);
lineto(90,5+(i-1)*95);
lineto(90,i*95);
lineto(5,i*95);
lineto(5,5+(i-1)*95);
TImage(image).Height:=95*kilk+10;
end;
end;
end;
{=========================================================}
procedure graphimsmall(im,n:integer;d:array of point;mxy,xcf,ycf,xce,yce:real); // малює саме
var i:integer; //зображення деталі на малюнку зліва
xr,yr:array[0..100]of integer;
image:TComponent;
begin
image := fMain.FindComponent('SmallIm' + IntToStr(im));
for i:=0 to n-1 do begin
xr[i]:=round((d[i].x-xcf)*mxy+xce);
yr[i]:=round((-d[i].y+ycf)*mxy+yce);
end;
with TImage(image).Canvas do begin
pen.Color:=clblack;
for i:=0 to n-1 do
if i=0 then moveto(xr[i],yr[i])
else lineto(xr[i],yr[i]);
end;
end;
{=========================================================}
procedure graphim1(n:integer;d:array of point;mxy,xce,yce,xp,yp:real;p,q:integer);
var i:integer; //малює вибране зображення в іншому масштабі
xr,yr:array[0..100]of integer;
begin
for i:=0 to n-1 do begin
xr[i]:=round((d[i].x+xp)*mxy+xce);
yr[i]:=round((-d[i].y-yp)*mxy+yce);
end;
with fmain.MainIm1.Canvas do begin
pen.Width:=p;
if q=1 then pen.Color:=clblack
else if q=2 then pen.Color:=clblue;
for i:=0 to n-1 do
if i=0 then moveto(xr[i],yr[i])
else lineto(xr[i],yr[i]);
end;
end;
{=========================================================}
procedure obhod(n:integer;a :figure;var b :figure); //перенумерація вершин
var i,NmaxY,NminY,NmaxX:integer;
begin
elmaxy(n,a,NmaxY);
if NmaxY=0 then NmaxY:=n-1;
elminy(n,a,NminY);
elmaxx(n,a,NmaxX);
if (NminY<=NmaxX) and (NmaxX<=NmaxY) then begin
b:=a;
exit;
end else for i:=0 to n-1 do begin
b[i].x:=a[n-i-1].x;
b[i].y:=a[n-i-1].y;
end;
end;
{=========================================================}
procedure godog(nn,nr:integer;fn,fr:figure;var m:integer;var gxy:figure);
var i,j:integer; //будує годограф навколо фігури fn і повертає у вигляді фігури
dc:real; //gxy з m точок
begin
m:=0; i:=0; j:=0; //скидаємо показники точок
fn[nn]:=fn[1]; //кінцева точка фігури співпадає з першою
fr[nr]:=fr[1]; //кінцева точка фігури співпадає з першою
gxy[m].x:=fn[i].x-fr[j].x;//координата х годографа
gxy[m].y:=fn[i].y-fr[j].y;//координата у годографа
repeat //повторювати
dc:=(fn[i+1].x-fn[i].x)*(fr[j+1].y-fr[j].y)-
(fr[j+1].x-fr[j].x)*(fn[i+1].y-fn[i].y);//перевірка знаку обходу
inc(m);
if dc>0 then j:=j+1 //якщо "+", то збільшуємо показник точок рухомої фігури
else if dc<0 then i:=i+1 //якщо "-", то збільшуємо показник точок нерухомої фігури
else begin //якщо "0", то збільшуємо показники точок і рухомої і нерухомої фігури
j:=j+1;
i:=i+1;
end;
gxy[m].x:=fn[i].x-fr[j].x;
gxy[m].y:=fn[i].y-fr[j].y;
until (gxy[m].x=gxy[0].x)and(gxy[m].y=gxy[0].y);//поки кінцева точка годографа не співпадатиме з першою
inc(m);
end;
{=========================================================}
procedure prg_info(flg:byte);
var fHlp:TForm;
mfield:TMemo;
bClose:TBitBtn;
begin
fHlp:=TForm.Create(fMain);
with fHlp do begin
Caption:='Довідка програми - ';
Position:=poMainFormCenter;
Width:=520;
Height:=350;
Show;
end;
mfield:=TMemo.Create(fHlp);
with mfield do begin
top:=2;
left:=2;
Width:=fHlp.ClientWidth-5;
Height:=fHlp.ClientHeight-35;
parent:=fHlp;
end;
bClose:=TBitBtn.Create(fHlp);
with bClose do begin
top:=fHlp.ClientHeight-30;
left:=(mfield.Width-75) div 2;
parent:=fHlp;
kind:=bkClose;
end;
if flg=0 then begin
mfield.Clear;
fHlp.Caption:=fHlp.Caption + fMain.MenuItem6.Caption;
mfield.Lines.LoadFromFile(ExtractFileDir(ParamStr(0))+'\help\prg.txt');
end;
if flg=1 then begin
mfield.Clear;
fHlp.Caption:=fHlp.Caption + fMain.MenuItem7.Caption;
mfield.Lines.LoadFromFile(ExtractFileDir(ParamStr(0))+'\help\help.txt');
end;
end;
{=========================================================}
end.
фрагмент
unit computations_ukl;
interface
uses Graphics, SysUtils, computations;
function minR(n:integer;a :array of real):real;
function maxR(n:integer;a :array of real):real;
Procedure Uk1;
Procedure Uk_God4;
Procedure Uk24(k:integer);
Procedure TocPer4(k:integer; Var Xn,Yn,Xv,Yv:real);
Procedure grafdet4(xa1,ya1,xa2,ya2:real);
procedure sortresh4(var xa1,ya1,xa2,ya2:real);
Procedure Uk_God6;
Procedure Uk26(k:integer);
Procedure TocPer6(k:integer; Var Xn,Yn,Xv,Yv:real);
Procedure grafdet6(xa1,ya1,xa2,ya2,xq,yq:real);
Procedure sortresh6(var xa1,ya1,xa2,ya2,qx,qy:real);
procedure shminit(xp,yp:real);
Procedure PDet(n1,n2:integer; Var d1,d2:figure; Var b:boolean);
procedure paral(x1,y1,x2,y2,x3,y3,x4,y4,xcf,ycf,xce,yce,mxy:real);
function pospointdet(n:integer;d:figure; x0,y0:real): boolean;
implementation
uses uMain;
{============================================================}
function minR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
zam:real;
begin
zam:=a[0];
for i:=1 to n-1 do
if a[i]<zam then zam:=a[i];
minR:=zam;
end;
{=========================================================}
function maxR(n:integer;a :array of real):real;
var i:integer; //знаходимо мінімальний елемент
zam:real;
begin
zam:=a[0];
for i:=1 to n-1 do
if a[i]>zam then zam:=a[i];
maxR:=zam;
end;
{=========================================================}
Procedure Uk1;
var i:integer;
phi:real;
begin
phi:=ang*pi/180;
if (fMain.rbhundredeightydegree.Checked) then
for i:=0 to fMain.kilkpointdet_r[nd_a]-1 do begin
fMain.fn[i].x:=fMain.dets_r[nd_a][i].x*cos(phi)-fMain.dets_r[nd_a][i].y*sin(phi);
fMain.fn[i].y:=fMain.dets_r[nd_a][i].y*sin(phi)+fMain.dets_r[nd_a][i].y*cos(phi);
fMain.fr[i].x:=-fMain.fn[i].x;
fMain.fr[i].y:=-fMain.fn[i].y;
end else begin
fMain.fn:=fMain.dets_r[nd_a];
fMain.fr:=fMain.fn;
end;
end;
{=========================================================}
Procedure Uk_God6; //
var NmaxX,NminX:integer;
begin
elmaxX(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX);
sort(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX,fMain.fn);
elminx(fMain.kilkpointdet_r[nd_a],fMain.fr,NminX);
sort(fMain.kilkpointdet_r[nd_a],fMain.fr,NminX,fMain.fr);
godog(fMain.kilkpointdet_r[nd_a],fMain.kilkpointdet_r[nd_a],fMain.fn,fMain.fr,mgod1,god1);
end;
{=======================================================}
Procedure Uk_God4; //
var NmaxX,NminX:integer;
fq:figure;
begin
elmaxX(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX);
sort(fMain.kilkpointdet_r[nd_a],fMain.fn,NmaxX,fMain.fn);
elminx(fMain.kilkpointdet_r[nd_a],fMain.fn,NminX);
sort(fMain.kilkpointdet_r[nd_a],fMain.fn,NminX,fq);
godog(fMain.kilkpointdet_r[nd_a],fMain.kilkpointdet_r[nd_a],fMain.fn,fq,mgod,god);
end;
{=========================================================}
Procedure Uk24(k:integer);
var i:integer;
begin
for i:=0 to mgod-1 do begin
god_r[i].x:= god[i].x+god[k].x;
god_r[i].y:= god[i].y+god[k].y;
end;
end;
{=========================================================}
Procedure Uk26(k:integer);
var i:integer;
begin
for i:=0 to mgod-1 do begin
god_r[i].x:= god[i].x+god1[k].x;
god_r[i].y:= god[i].y+god1[k].y;
end;
end;
{=========================================================}
Procedure TocPer4(k:integer; Var Xn,Yn,Xv,Yv:real);
var i,j,p,prizline,q:integer;
x0a,y0a,x0b,y0b,delta:real;
xverch,yverch,xnizh,ynizh:array [1..10] of real;
begin
p:=0;q:=0;
for i:=0 to mgod-2 do
for j:=0 to mgod-2 do begin
perline(god[i].x, god[i].y,god[i+1].x, god[i+1].y,god_r[j].x, god_r[j].y,
god_r[j+1].x, god_r[j+1].y, prizline, x0a,y0a,x0b,y0b);
if (prizline=1) or (prizline=2) or (prizline=3) then begin
delta:=god[k].y*x0a-god[k].x*y0a;
if delta>0 then begin
p:=p+1;
xverch[p]:=x0a;
yverch[p]:=y0a;
end else begin
q:=q+1;
xnizh[q]:=x0a;
ynizh[q]:=y0a;
end;
end;
end;
Xn:=xnizh[q];
Yn:=ynizh[q];
Xv:=xverch[p];
Yv:=yverch[p];
end;
{=========================================================}
Procedure TocPer6(k:integer; Var Xn,Yn,Xv,Yv:real);
var i,j,p,prizline,q:integer;
x0a,y0a,x0b,y0b,delta:real;
xverch,yverch,xnizh,ynizh:array [1..10] of real;
begin
p:=0;q:=0;
for i:=0 to mgod1-2 do
for j:=0 to mgod-2 do begin
perline(god1[i].x, god1[i].y,god1[i+1].x, god1[i+1].y,god_r[j].x, god_r[j].y,
god_r[j+1].x, god_r[j+1].y, prizline, x0a,y0a,x0b,y0b);
if (prizline=1) or (prizline=2) or (prizline=3) then begin
delta:=god1[k].y*x0a-god1[k].x*y0a;
if delta>0 then begin
p:=p+1;
xverch[p]:=x0a;
yverch[p]:=y0a;
end else begin
q:=q+1;
xnizh[q]:=x0a;
ynizh[q]:=y0a;
end;
end;
end;
Xn:=xnizh[q];
Yn:=ynizh[q];
Xv:=xverch[p];
Yv:=yverch[p];
end;
{=========================================================}
Procedure grafdet4(xa1,ya1,xa2,ya2:real);
{=========================================================}
procedure grafpar(mxy,xce,yce,xp,yp:real);
var i:integer;
xr1,yr1:array[0..5]of integer;
xr,yr:array[0..5]of real;
begin
xr[0]:=0; yr[0]:=0;
xr[1]:=xa2; yr[1]:=ya2;
xr[2]:=xa1+xa2; yr[2]:=ya1+ya2;
xr[3]:=xa1; yr[3]:=ya1;
xr[4]:=0; yr[4]:=0;
for i:=0 to 4 do begin
xr1[i]:=round((xr[i]+xp)*mxy+xce);
yr1[i]:=round((-yr[i]-yp)*mxy+yce);
end;
with fmain.imgMain1.Canvas do begin
pen.Color:=clblue;
for i:=0 to 4 do
if i=0 then moveto(xr1[i],yr1[i])
else lineto(xr1[i],yr1[i]);
end;
end;
{=========================================================}
begin
fMain.imgMain1.Picture:=nil;
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,0,0,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,xa1,ya1,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,xa2,ya2,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/4,xe,ye,xa1+xa2,ya1+ya2,ang);
grafpar(mashim1/4,0,0,xe,ye);
end;
{=========================================================}
Procedure grafdet6(xa1,ya1,xa2,ya2,xq,yq:real);
{=========================================================}
procedure grafpar(mxy,xce,yce:real);
var i:integer;
xr1,yr1:array[0..5]of integer;
xr,yr:array[0..5]of real;
begin
xr[0]:=0; yr[0]:=0;
xr[1]:=xa1; yr[1]:=ya1;
xr[2]:=xa1+xa2; yr[2]:=ya1+ya2;
xr[3]:=xa2; yr[3]:=ya2;
xr[4]:=xr[0]; yr[4]:=yr[0];
for i:=0 to 4 do begin
xr1[i]:=round((xr[i])*mxy+xce);
yr1[i]:=round((-yr[i])*mxy+yce);
end;
with fmain.imgMain1.Canvas do begin
pen.Color:=clblue;
for i:=0 to 4 do
if i=0 then moveto(xr1[i],yr1[i])
else lineto(xr1[i],yr1[i]);
end;
end;
{=========================================================}
begin
fMain.imgMain1.Picture:=nil;
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,0,0,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,xa1,ya1,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,xa2,ya2,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fn,mashim1/5,xe,ye,xa1+xa2,ya1+ya2,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fr,mashim1/5,xe,ye,xq+xa1,yq+ya1,ang);
graphim1(fMain.kilkpointdet_r[nd_a],fMain.fr,mashim1/5,xe,ye,xq,yq,ang);
grafpar(mashim1/5,xe,ye);
end;
{=========================================================}
procedure sortresh4(var xa1,ya1, xa2,ya2:real);
var i:integer;
maxd,d:real;
begin
i:=0;
xa1:=a1x[i];
ya1:=a1y[i];
xa2:=a2x[i];
ya2:=a2y[i];
maxd:=abs(a1x[i]*a2y[i]-a1y[i]*a2x[i]);
for i:=1 to mgod-1 do begin
d:=abs(a1x[i]*a2y[i]-a1y[i]*a2x[i]);
if maxd>d then begin
xa1:=a1x[i];
ya1:=a1y[i];
xa2:=a2x[i];
ya2:=a2y[i];
maxd:=d;
end;
end;
end;
{=========================================================}
procedure sortresh6(var xa1,ya1, xa2,ya2,qx,qy:real);
var i:integer;
maxd,d:real;
begin
i:=0;
xa1:=a1x[i];
ya1:=a1y[i];
xa2:=a2x[i];
ya2:=a2y[i];
qx:=gx[i];
qy:=gy[i];
maxd:=abs(a1x[i]*a2y[i]-a1y[i]*a2x[i]);
for i:=1 to mgod1-1 do begin
d:=a1x[i]*a2y[i]-a1y[i]*a2x[i];
if maxd>d then begin
xa1:=a1x[i];
ya1:=a1y[i];
xa2:=a2x[i];
ya2:=a2y[i];
qx:=gx[i];
qy:=gy[i];
maxd:=d;
end;
end;
end;
{=========================================================}
procedure shminit(xp,yp:real);
begin
inc(kdet);
with shm[kdet] do begin
numdet:=nd_m;
x_p:=xp;
y_p:=yp;
phi:=angle;
pr:=1;
end;
end;
{=========================================================}
Procedure PDet(n1,n2:integer; Var d1,d2:figure; Var b:boolean);
Var i:integer;
Bp:boolean;
Begin
B:=False;
for i:=0 to n2-1 do begin
bp:=pospointdet(n1,d1,d2[i].x,d2[i].y);
if bp then begin
b:=Bp;
exit
end;
end;
for i:=0 to n1-1 do begin
bp:=pospointdet(n2,d2,d1[i].x,d1[i].y);
if bp then begin
b:=Bp;
exit
end;
end;
End;
{============================================================}
procedure paral(x1,y1,x2,y2,x3,y3,x4,y4,xcf,ycf,xce,yce,mxy:real);
var
i:integer; //малює вибране зображення в іншому масштабі
xr,yr:array[0..4]of integer;
xr1,yr1:array[0..4]of real;
begin
xr1[0]:=x1; yr1[0]:=y1;
xr1[1]:=x2; yr1[1]:=y2;
xr1[2]:=x3; yr1[2]:=y3;
xr1[3]:=x4; yr1[3]:=y4;
xr1[4]:=x1; yr1[4]:=y1;
for i:=0 to 4 do begin
xr[i]:=round((xr1[i]+xcf)*mxy+xce);
yr[i]:=round((yr1[i]+ycf)*mxy+yce);
end;
with fMain.imgMain2.Canvas do begin
pen.Width:=1;
pen.Mode:=pmcopy;
pen.Color:=clgreen;
for i:=0 to 4 do
if i=0 then moveto(xr[i],yr[i])
else lineto(xr[i],yr[i]);
end;
end;
{============================================================}
function pospointdet(n:integer;d:figure; x0,y0:real): boolean;
var i,k:integer;
t1,t2,t:real;
begin
pospointdet:=false; k:=0;
for i:=0 to n-2 do begin
if d[i].y=d[i+1].y then continue;
if (d[i].y>y0) and (d[i+1].y>y0) then continue;
if (d[i].y<y0) and (d[i+1].y<y0) then continue;
if d[i].y>d[i+1].y then begin
t1:= d[i+1].y; t2:= d[i].y;
end else begin
t1:= d[i].y; t2:= d[i+1].y;
end;
if t1=y0 then continue
else if t2=y0 then k:=k+1
else begin
t:=(y0-d[i].y)/(d[i+1].y-d[i].y);
if (t>0) and (t<1) and (d[i].x+t*(d[i+1].x-d[i].x)>=x0) then k:=k+1;
end;
end;
if odd(k) then pospointdet:=true;
end;
{============================================================}
end.
