PROGRAM CURVE_PARAMETRICHE(input,output);
(* produced by Marcello Mengoni - www.mengoni.org *)
uses
crt,Graph;
const
pigreco=3.1415927;
var
grDriver : Integer;
grMode : Integer;
scala,colore,spc:integer;
axc,xx,yy,zz,za:integer;
xassex,yassex,xassey,yassey:integer;
angxoz,angxoy,angyoz:real;
xestrassex,yestrassex,xestrassey,yestrassey:integer;
convx,convy:real;
x,y,z:real;
valore:integer;
precedente:array[1..700] of integer;
indice:integer;
t,a,b:real;
k:integer;
(*************************************************************************)
function POT(fpa,fpb:real):real;
var
fpc,fpe:integer;
fpd:real;
begin
fpe:=trunc(fpb);
fpd:=1;
for fpc:=1 to fpe do
fpd:=fpd*fpa;
pot:=fpd
end;
function sgn(fs:real):integer;
begin
if fs<>0 then
sgn:=trunc(fs/(abs(fs)))
else
sgn:=1
end;
function fraz(ff:real):real;
begin
fraz:=ff-trunc(ff)
end;
procedure quesito(spazio,altezza:integer);
var
ascii:char;
ch,decine,conta,potenza:integer;
numero:array[1..6] of integer;
begin
decine:=0;
repeat
ch:=ord(readkey);
if (ch>47) and (ch<58) then
begin
decine:=decine+1;
numero[decine]:=ch-48;
spazio:=spazio+10;
ascii:=char(ch);
outtextxy(spazio,altezza,ascii);
end;
until ch=13;
valore:=0;
for conta:=1 to decine do
begin
potenza:=decine-conta;
valore:=valore+numero[conta]*trunc(pot(10,potenza));
end;
end;
procedure assonometria;
var
ch:integer;
begin
angxoz:=5/4*pigreco;
angxoy:=7/4*pigreco;
angyoz:=1/2*pigreco;
yestrassex:=trunc(350-sin(angxoz)*100);
xestrassex:=trunc(320+cos(angxoz)*100);
yestrassey:=trunc(350-sin(angxoy)*100);
xestrassey:=trunc(320+cos(angxoy)*100);
initgraph(grdriver,grmode,'');
outtextxy(180,10,'DEFINIZIONE DELL'' ASSONOMETRIA');
outtextxy(145,70,'Premere " X " per selezionare l''asse x');
outtextxy(145,90,'Premere " Y " per selezionare l''asse y');
outtextxy(50,110,'Usare le frecce destra e sinistra per lo spostamento dell''asse');
outtextxy(145,130,'Pemere RETURN per chiudere la selezione');
line(320,250,320,350);
line(320,350,xestrassex,yestrassex);
line(320,350,xestrassey,yestrassey);
circle(320,350,15);
repeat
ch:=ord(readkey);
case ch of
120:begin
repeat
ch:=ord(readkey);
case ch of
75:begin
setcolor(0);
line(320,350,xestrassex,yestrassex);
angxoz:=angxoz-pigreco/120;
yestrassex:=trunc(350-sin(angxoz)*100);
xestrassex:=trunc(320+cos(angxoz)*100);
setcolor(15);
circle(320,350,15);
line(320,350,xestrassex,yestrassex);
end;
77:begin
setcolor(0);
line(320,350,xestrassex,yestrassex);
angxoz:=angxoz+pigreco/120;
yestrassex:=trunc(350-sin(angxoz)*100);
xestrassex:=trunc(320+cos(angxoz)*100);
setcolor(15);
circle(320,350,15);
line(320,350,xestrassex,yestrassex);
end;
end; (* case *)
until (ch=13) or (ch=121)
end;
121:begin
repeat
ch:=ord(readkey);
case ch of
75:begin
setcolor(0);
line(320,350,xestrassey,yestrassey);
angxoy:=angxoy-pigreco/120;
yestrassey:=trunc(350-sin(angxoy)*100);
xestrassey:=trunc(320+cos(angxoy)*100);
setcolor(15);
circle(320,350,15);
line(320,350,xestrassey,yestrassey);
end;
77:begin
setcolor(0);
line(320,350,xestrassey,yestrassey);
angxoy:=angxoy+pigreco/120;
yestrassey:=trunc(350-sin(angxoy)*100);
xestrassey:=trunc(320+cos(angxoy)*100);
setcolor(15);
circle(320,350,15);
line(320,350,xestrassey,yestrassey);
end;
end; (* case *)
until (ch=13) or (ch=120)
end;
end; (* case *)
until ch=13;
end;
function adattatore(getmaxx,scala:integer):integer;
var
faa,fac,fad,fae,fak:real;
fab,faf,fag:integer;
begin
fag:=getmaxx;
fak:=fag/2;
faf:=0;
repeat
faa:=fak/scala;
fab:=trunc(faa);
fac:=faa-fab;
if fac < 0.5 then
fae:=0
else
begin
fab:=trunc(faa+1);
fae:=1
end;
fad:=abs(faa-fab);
if fad < 0.5 then
faf:=1
else
begin
if fae =1 then
fak:=fak+1
else
fak:=fak-1
end;
until faf=1;
adattatore:=fab
end;
procedure assi;
begin
setcolor(8);
yestrassex:=trunc(239-sin(angxoz)*320);
xestrassex:=trunc(319+cos(angxoz)*320);
yestrassey:=trunc(239-sin(angxoy)*320);
xestrassey:=trunc(319+cos(angxoy)*320);
line(319,0,319,480);
line(319,239,xestrassex,yestrassex);
line(319,239,xestrassey,yestrassey);
yestrassex:=trunc(239+sin(angxoz)*320);
xestrassex:=trunc(319-cos(angxoz)*320);
yestrassey:=trunc(239+sin(angxoy)*320);
xestrassey:=trunc(319-cos(angxoy)*320);
line(319,0,319,480);
line(319,239,xestrassex,yestrassex);
line(319,239,xestrassey,yestrassey);
setcolor(15);
end;
procedure unita(axc,getmaxx,getmaxy,scala:integer);
var
pub,puc,pud,puf,pug,puh,pui,pul,pum:integer;
begin
setcolor(8);
puc:=adattatore(getmaxx,scala);
for pub:=-scala to (scala-1) do
begin
pud:=trunc(319+cos(angxoz)*pub*puc);
puf:=trunc(239-sin(angxoz)*pub*puc);
pul:=trunc(319-cos(angxoy)*pub*puc);
pum:=trunc(239+sin(angxoy)*pub*puc);
pui:=-(pub*puc)+trunc(getmaxy/2);
line(pud,puf-3,pud,puf+3); (* asse x *)
line(316,pui,322,pui); (* asse z *)
line(pul,pum-3,pul,pum+3); (* asse y *)
end;
setcolor(15);
end;
(*************************************************************************)
begin
grDriver := Detect;
InitGraph(grDriver,grMode,'');
outtextxy(10,100,'dimmi la scala (standard = 11) ');
quesito(270,100);
scala:=valore;
outtextxy(10,200,'dimmi di che colore vuoi la curva (standard = 4) ');
quesito(440,200);
colore:=valore;
assonometria;
InitGraph(grDriver,grMode,'');
(*************************************************************************)
assi;
axc:=adattatore(getmaxx,scala);
unita(axc,getmaxx,getmaxy,scala);
a:=-10*2*pigreco;
b:=10*2*pigreco;
t:=a;
for k:=trunc(a*axc) to trunc(b*axc) do
begin
(****** EQUAZIONE PARAMETRICA **********)
(***********) x:=cos(t); (**************)
(***********) y:=sin(t); (**************)
(***********) z:=1/4*t; (**************)
(***************************************)
xassey:=trunc((y*axc)*cos(angxoy)+319);
yassey:=trunc((y*axc)*sin(angxoy)+239);
xassex:=trunc((x*axc)*cos(angxoz)+319);
yassex:=trunc((x*axc)*sin(angxoz)+239);
xx:=xassex+xassey-319;
yy:=yassex+yassey-239;
zz:=yy-(trunc(z)*axc+round(fraz(z)*axc));
putpixel(xx,zz,colore);
t:=t+1/axc
end; (* for t *)
outtextxy(450,470,'RETURN per continuare');
(*************************************************************************)
ReadLn;
CloseGraph
end.