Программирование на Pascal.
1.Развевающийся российский флаг.
2.Вращение тетрайдера. 3.Вращение сферы.
Эта замечательная программа выводит на экран развевающийся российский флаг.
Эта программа реализует вращение тетрайдера в трех плоскостях.
Эта программа демонстрирует вращение сферы.
Предоставил Дарданов Александр.
program flag;
uses crt, dos;
const
spd = 1;
size = 3;
curve = 125;
Xmax = 250 div size;
Ymax = 150 div size;
sofs = 30;
samp = 8;
slen = 255;
type
screenbuffertype = array [0..63999] of byte;
screenbufferptr = ^screenbuffertype;
var
buffer : screenbufferptr;
screen_y : array [0..199] of word;
stab : array [0..slen] of word;
procedure calcscreeny (width : word);
var
i : integer;
begin
for i := 0 to 199 do
screen_y [i] := i * width;
end;
procedure Init_Graph;
var
reg : registers;
begin
reg.AH := $00;
reg.AL := $13;
intr ($10, reg);
buffer := ptr ($A000, 0);
calcscreeny (320);
end;
procedure Close_Graph;
var
reg : registers;
begin
reg.AH := $00;
reg.AL := $03;
intr ($10, reg);
end;
procedure csin;
var
i : byte;
begin
for i := 0 to slen do
stab [i] := round (sin (i * 4 * Pi / slen) * samp) + sofs;
end;
procedure display_flag;
type
scrarray = array [0..Xmax,0..Ymax] of byte;
var
postab : array [0..Xmax,0..Ymax] of word;
bitmap : scrarray;
x, y, xp ,yp, sidx : word;
begin
sidx := 0;
for x := 0 to Xmax do
for y := 0 to (Ymax div 3) do
bitmap [x,y] := white;
for x := 0 to Xmax do
for y := (Ymax div 3) to 2 * (Ymax div 3) do
bitmap [x,y] := lightblue;
for x := 0 to Xmax do
for y := 2 * (Ymax div 3) to Ymax do
bitmap [x,y] := lightred;
for x := 0 to Xmax do
for y := 0 to Ymax do
postab [x,y] := 0;
repeat
for x := 0 to Xmax do
for y := Ymax downto 0 do
begin
buffer^ [postab [x,y]] := 0;
xp := size * x + stab [(sidx + curve * (x + y)) mod slen];
yp := size * y + stab [(sidx + 4 * x + (curve + 1) * y) mod slen];
postab [x,y] := xp + screen_y [yp];
buffer^ [postab [x,y]] := bitmap [x,y];
end;
sidx := (sidx + spd) mod slen;
delay(1000);
until KeyPressed;
end;
begin
csin;
init_graph;
display_flag;
close_graph;
end.
PROGRAM tetraedr;
USES crt, graph;
CONST alf = 2 ;
bet = 3 ;
gum = 4 ;
gran1:array[1..10] of integer =
(1, 2, 3, 4, 5, 6, 7, 8, 9, 10);
color = 2;
style = 10;
VAR x, y, z:array[1..12] of real; a,
r:real; k, h, x1, y1, z1, x0, y0,
z0:real; jl, bn, gd, gm,i:integer;
pg:byte;
PROCEDURE povorot(a, b, c:real );
CONST RAD = pI/180;
VAR i, t:integer; cos1, sin1, cos2, sin2, cos3, sin3, x1, y1, z1:real;
BEGIN
cos1:=cos ( alf * rad );
sin1:=sin ( alf * rad );
cos2:=cos ( bet * rad );
sin2:=sin ( bet * rad );
sin3:=sin ( gum * rad );
cos3:=cos ( gum * rad );
For t:=1 to 12 do
BEGIN
x1:=a + (x[t]-a) * cos1 - (y[t]-b) * sin1;
y1:=b + (x[t]-a) * sin1 + (y[t]-b) * cos1;
z1:=z[t]; x[t]:=x1; y[t]:=y1; z[t]:=z1;
END;
For t:=1 to 12 do
BEGIN
x1:=a + (x[t]-a) * cos2 + (z[t]-c) * sin2;
z1:=c - (x[t]-a) * sin2 + (z[t]-c) * cos2;
y1:=y[t]; x[t]:=x1; y[t]:=y1; z[t]:=z1;
END;
For t:=1 to 12 do
BEGIN
y1:=b + (y[t]-b) * cos3 - (z[t]-c) * sin3;
z1:=c + (y[t]-b) * sin3 + (z[t]-c) * cos3;
x1:=x[t]; x[t]:=x1; y[t]:=y1; z[t]:=z1;
END;
END;
function prov(x1,x2,x3,y1,y2,y3,z1,z2,z3:real):boolean;
var l,k,a,b,c,d:real; xc,yc,zc:real;
begin
a:=(y2-y1)*(z3-z1)-(z2-z1)*(y3-y1);
b:=(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1);
c:=(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1);
xc:=(x[1]+x[2]+x[3]+x[4]+x[5]+x[6]+x[7]+x[8]+x[9]+x[10]+x[11]+x[12])/12;
yc:=(y[1]+y[2]+y[3]+y[4]+y[5]+y[6]+y[7]+y[8]+y[9]+y[10]+y[11]+y[12])/12;
zc:=(z[1]+z[2]+z[3]+z[4]+z[5]+z[6]+z[7]+z[8]+z[9]+z[10]+z[11]+z[12])/12;
d:=-a*x1-b*y1-c*z1; l:=a*xc+b*yc+c*zc+d;
if l>=0 then k:=1 else k:=-1;
if c*k/sqrt(a*a+b*b+c*c)>0 then prov:=true
else prov:=false;
end;
procedure gran(s,kl,jm,vb,gg:integer);
var fg:array[1..10] of integer ;
begin
fg[1]:=round(x[s]+k); fg[2]:=round(y[s]+h); fg[3]:=round(x[kl]+k);
fg[4]:=round(y[kl]+h); fg[5]:=round(x[jm]+k); fg[6]:=round(y[jm]+h);
fg[7]:=round(x[vb]+k); fg[8]:=round(y[vb]+h); fg[9]:=round(x[s]+k);
fg[10]:=round(y[s]+h); Setcolor(color); SetFillstyle(style,gg);
Fillpoly(4,fg);
end;
procedure rr(ss1,ss2,ss3,ss4:integer);
begin
if (y0+r+r/2+h)>=ss4 then begin bn:=-abs(bn); end;
if (x0+r+r/2+k)>=ss3 then begin jl:=-abs(jl); end;
if (y0-r-r/2+h)<=ss2 then begin bn:= abs(bn); end;
if (x0-r-r/2+k)<=ss1 then begin jl:= abs(jl); end;
End;
PROCEDURE init_tetr;
begin
write('введите размер грани r=');
readln(r); if r>100 then r:=100;
gd:=VGA;
gm := VGAMed;
initgraph(gd,gm,'C:\TP2\BGI'); {здесь нужно подставить путь к вашему драйверу}
X0:=GetMaxX div 2; Y0:=GetMaxY div 2;
Z0:=40; pg:=0; k:=0; h:=0; jl:=3; bn:=2; a:=0;
x[1]:= X0 + R * cos(a); x[2]:= x0 + R * cos(a+pi/3);
x[3]:= x0 + R * cos(a+(2 * pi/3)); x[4]:= x0 + R * cos(a+pi);
x[5]:= x0 + R * cos(a-(2 * pi/3)); x[6]:= x0 + R * cos(a-pi/3);
x[7]:= X0 + R * cos(a); x[8]:= x0 + R * cos(a+pi/3);
x[9]:= x0 + R * cos(a+(2 * pi/3)); x[10]:= x0 + R * cos(a+pi);
x[11]:= x0 + R * cos(a-(2 * pi/3)); x[12]:= x0 + R * cos(a-pi/3);
y[1]:= y0 + R * sin(a); y[2]:= y0 + R * sin(a+pi/3);
y[3]:= y0 + R * sin(a+(2 * pi/3)); y[4]:= y0 + R * sin(a+pi);
y[5]:= y0 + R * sin(a-(2 * pi/3)); y[6]:= y0 + R * sin(a-pi/3);
y[7]:= y0 + R * sin(a); y[8]:= y0 + R * sin(a+pi/3);
y[9]:= y0 + R * sin(a+(2 * pi/3)); y[10]:= y0 + R * sin(a+pi);
y[11]:= y0 + R * sin(a-(2 * pi/3)); y[12]:= y0 + R * sin(a-pi/3);
z[1]:= z0 - r/2 - r/2; z[2]:= z0 - r/2;
z[3]:= z0 - r/2; z[4]:= z0 - r/2 - r/2;
z[5]:= z0 - r/2; z[6]:= z0 - r/2;
z[7]:= z0 + r/2 + r/2; z[8]:= z0 + r/2;
z[9]:= z0 + r/2; z[10]:= z0 + r/2 + r/2;
z[11]:= z0 + r/2; z[12]:= z0 + r/2;
repeat
SetActivePage(pg);
ClearViewPort;
povorot(x0,y0,z0);
K:=k+jl; h:=h+bn;
rr(0,0,getmaxx,getmaxy);
IF prov(x[5],x[11],x[12],y[5],y[11],y[12],z[5],z[11],z[12])
THEN gran(5,11,12,6,gran1[1]);
IF prov(x[4],x[5],x[6],y[4],y[5],y[6],z[4],z[5],z[6])
THEN gran(4,5,6,1,gran1[2]);
IF prov(x[1],x[2],x[3],y[1],y[2],y[3],z[1],z[2],z[3])
THEN gran(1,2,3,4,gran1[3]);
IF prov(x[9],x[3],x[2],y[9],y[3],y[2],z[9],z[3],z[2])
THEN gran(9,3,2,8,gran1[4]);
IF prov(x[5],x[11],x[10],y[5],y[11],y[10],z[5],z[11],z[10])
THEN gran(5,11,10,4,gran1[5]);
IF prov(x[4],x[10],x[9],y[4],y[10],y[9],z[4],z[10],z[9])
THEN gran(4,10,9,3,gran1[6]);
IF prov(x[11],x[12],x[7],y[11],y[12],y[7],z[11],z[12],z[7])
THEN gran(11,12,7,10,gran1[7]);
IF prov(x[10],x[7],x[8],y[10],y[7],y[8],z[10],z[7],z[8])
THEN gran(10,7,8,9,gran1[8]);
IF prov(x[12],x[6],x[1],y[12],y[6],y[1],z[12],z[6],z[1])
THEN gran(12,6,1,7,gran1[9]);
IF prov(x[1],x[7],x[8],y[1],y[7],y[8],z[1],z[7],z[8])
THEN gran(1,7,8,2,gran1[10]);
SetVisualPage(pg); pg:=1-pg;
Until keypressed;
end;
BEGIN
init_tetr;
closegraph;
END.
program rotating_sphere;
uses crt, graph;
var gd,gm:integer;
type
Point3D = record
x, y, z : real;
end;
Base2D = record
u, v : integer;
end;
var
data : array [0..25, 0..40] of Point3D;
m, t1, t2 : integer;
ch : char;
base : Base2D;
e : real;
perspective : boolean;
const
rad = Pi / 180;
procedure spher_to_cartesian (radius, a, b : integer; var p : Point3D);
var
s1, s2, s3, c1, c2, c3 : real;
begin
s1 := sin (a * rad);
s2 := sin (b * rad);
c1 := cos (a * rad);
c2 := cos (b * rad);
p.x := radius * c1 * c2;
p.y := radius * c1 * s2;
p.z := radius * s1;
end;
procedure Rotate (angleX, angleY, angleZ : integer; var p : Point3D);
var
s1, s2, s3, c1, c2, c3 : real;
Puit : Point3D;
begin
s1 := sin (angleX * rad);
s2 := sin (angleY * rad);
s3 := sin (angleZ * rad);
c1 := cos (angleX * rad);
c2 := cos (angleY * rad);
c3 := cos (angleZ * rad);
Puit.X := p.x * (c2 * c3) + p.y * (c2 * s3) - p.z * s2;
Puit.Y := p.x * (s1 * s2 * c3 - c1 * s3) + p.y * (s1 * s2 * s3 + c1 * c3) +
p.z * (s1 * c2);
Puit.Z := p.x * (c1 * s2 * c3 + s1 * s3) + p.y * (c1 * s2 * s3 - s1 * c3) +
p.z * (c1 * c2);
p := Puit;
end;
procedure init (radius, hor, ver : integer; hx, hy, hz : integer);
var
p1, p2 : Point3D;
a, b, hor_step, ver_step : real;
i, j : byte;
begin
for i := 0 to 25 do
for j := 0 to 40 do
begin
data [i,j].x := 0.0;
data [i,j].y := 0.0;
data [i,j].z := 0.0;
end;
t1 := 0;
hor_step := 180 / hor;
ver_step := 360 / ver;
for i := 0 to hor do
begin
b := 0;
a := - 90 + i * hor_step;
spher_to_cartesian (radius, trunc (a), trunc (b), p1);
rotate (hx, hy, hz, p1);
t2 := 0;
inc (t1);
data [t1,t2] := p1;
for j := 0 to ver do
begin
inc (t2);
b := j * ver_step;
spher_to_cartesian (radius, trunc (a), trunc (b), p2);
rotate (hx, hy, hz, p2);
data [t1,t2] := p2;
end;
end;
end;
procedure Rotation (x, y, z : real);
var
s1, s2, s3, c1, c2, c3 : real;
p, Puit : Point3D;
u, v : byte;
begin
s1 := sin (X * rad);
s2 := sin (Y * rad);
s3 := sin (Z * rad);
c1 := cos (X * rad);
c2 := cos (Y * rad);
c3 := cos (Z * rad);
for u := 0 to t1 do
for v := 0 to t2 do
begin
p := data [u,v];
Puit.X := p.x * (c2 * c3) + p.y * (c2 * s3) - p.z * s2;
Puit.Y := p.x * (s1 * s2 * c3 - c1 * s3) + p.y *
(s1 * s2 * s3 + c1 * c3) + p.z * (s1 * c2);
Puit.Z := p.x * (c1 * s2 * c3 + s1 * s3) + p.y *
(c1 * s2 * s3 - s1 * c3) + p.z * (c1 * c2);
data [u,v] := Puit;
end;
end;
procedure TransForm (Pt3D : Point3D; var X2D, Y2D : integer);
var
thit : real;
begin
if perspective then
begin
thit := 1 / (1 - Pt3D.X / e);
X2D := trunc (Base.u + Pt3D.y * thit);
Y2D := trunc (Base.v + Pt3D.z * thit);
end
else
begin
X2D := Base.u + round (Pt3D.y);
Y2D := Base.v + round (Pt3D.z);
end;
end;
procedure LineC (x1, y1, x2, y2 : integer; color : byte);
begin
SetColor (color);
Line (x1, y1, x2, y2);
end;
procedure Line3 (point1, point2 : Point3D; color : integer);
var
x1, x2, y1, y2 : integer;
begin
TransForm (point1, x1, y1);
TransForm (point2, x2, y2);
LineC (x1, y1, x2, y2, color);
end;
procedure Draw (color : byte);
var
u, v : byte;
begin
for u := 1 to t2 - 1 do
for v := 1 to t1 - 1 do
begin
Line3 (data [v,u], data [v + 1,u], color);
Line3 (data [v,u], data [v,u + 1], color);
end;
end;
begin
gd:=vga; gm:=vgamed;
{SetGraphMode (vgamed);}
initgraph(gd,gm,'c:\tp2\bgi');{подставте путь к своему гр. драйверу}
SetBkColor (blue);
base.u := 320;
base.v := 175;
perspective := false;
e := 150;
m := 1;
init (140, 20, 20, 40, - 55, 14);
ch := #32;
repeat
for m := 0 to 1 do
begin
SetVisualPage(m);
SetActivePage(m + 1);
ClearViewPort;
Rotation (- 0.5, 0.5, 3);
Draw (14);
end;
until keypressed;
end.