Previous Entry Share Next Entry
Песочные часы (FP)
Аватар
eolegv
Этой программой я открываю тему всевозможных часов, которые пришли мне в голову. Итак пришел я к этой программе, экспериментируя с параметрическими уравнениями эллипса, в одном таком эксперименте у меня получился знак бесконечность, если его перевернуть он будет напоминать песочные часы. Вот тогда мой пытливый ум захотел чтобы по ним ссыпался песок. Да помню долго времени ушло у меня на написания этой программы. Я её несколько раз забрасывал потов возвращался вновь, ну и в итоге у меня получилось, почти то что я хотел.
Вот текст этой программы

program sand;
uses graph,crt;
var m,f,r,m1,f1,r1:array[1..200] of integer;
      pol1,pol2,pol3,pol4:array[1..80,1..2] of integer;
n,q,q1,q2,q3,q22,q33,ss,sss,   a,b,c,x,y,dx,dy,i,j:integer;k,l,k1,l1,v:longint;
      z,p:integer; st,st1,st2:string;
procedure time;
var t,h:integer;
begin
k:=0;setcolor(white);
repeat
k:=k+1;
if trunc(sqrt(k))=sqrt(k) then l:=k;
if k<>l then
if (k-l+1)div 2=(k-l+1)/2 then
begin f1[(k-l+1)div 2]:=f1[(k-l+1)div 2]+2;
putpixel(f1[(k-l+1)div 2],m1[(k-l+1)div 2],red); end
else
begin r1[(k-l+1)div 2]:=r1[(k-l+1)div 2]-2;
putpixel(r1[(k-l+1)div 2],m1[(k-l+1)div 2],red); end else putpixel(dx,m1[trunc(sqrt(l))],red);
until k=21100;

i:=0;
setviewport(dx-200,dy-300,dx+200,dy+300,clipon);

repeat
i:=i+1;
x:=200+round(200*sin(0.04*i));
y:=300+round(400*cos(0.02*i));

if (i>=408)and(i<=435) then
begin pol1[i-407,1]:=x;pol1[i-407,2]:=y;end;
if (i>=507)and(i<=535) then
begin
pol2[i-506,1]:=x;pol2[i-506,2]:=y;end;
if (i>=568)and(i<=592) then
begin
pol3[i-567,1]:=x;pol3[i-567,2]:=y;end;
if (i>=664)and(i<=688) then
begin
pol4[i-663,1]:=x;pol4[i-663,2]:=y;end;
if i=700 then begin
pol1[28,1]:=-100;pol1[28,2]:=0;
pol1[29,1]:=-100;pol1[29,2]:=200;
pol2[29,1]:=+500;pol2[29,2]:=300;
pol2[30,1]:=+500;pol2[30,2]:=0;
pol4[25,1]:=500;pol4[25,2]:=400;
pol4[26,1]:=500;pol4[26,2]:=600;
pol3[25,1]:=-100;pol3[25,2]:=600;
pol3[26,1]:=-100;pol3[26,2]:=400;

for t:=1 to 29 do begin pol1[t,1]:=pol1[t,1]-1;pol3[t,1]:=pol3[t,1]-1;end;
for t:=1 to 30 do begin pol2[t,1]:=pol2[t,1]+1;pol4[t,1]:=pol4[t,1]+1;end;
                   end;
if (x<>200)and(y<>300) then
putpixel(x,y,white);
until i=4000;
setviewport(dx-200,dy-300,dx+200,dy+300,clipoff);
rectangle(-20,-30,420,0);
rectangle(-20,630,420,600);

setviewport(0,0,getmaxx,getmaxy,clipoff);
end;
procedure clean(kk:longint);
var
col:integer;
begin
col:=black;
setviewport(dx-200,dy-300,dx+200,dy+300,clipoff);
setfillstyle(1,col);setcolor(col);
if kk=1 then begin
fillpoly(29,pol1);
bar(-100,2,-2,150);
fillpoly(30,pol2);
bar(402,2,500,150);end else begin
fillpoly(26,pol3);
bar(-100,450,-2,598);
fillpoly(26,pol4);
bar(402,450,500,598); end;

setviewport(0,0,getmaxx,getmaxy,clipon);
end;

begin
a:=detect;
initgraph(a,b,'');
dx:=getmaxx div 2;
dy:=getmaxy div 2;

for i:=1 to 200 do begin f[i]:=dx;r[i]:=dx;end;
for i:=0 to 150 do m[i+1]:=dy+298-2*i;

for i:=0 to 150 do m1[i+1]:=dy-292+2*i;
for i:=1 to 200 do begin f1[i]:=dx;r1[i]:=dx;end;
time;clean(1);
for i:=0 to 150 do m1[i+1]:=dy-292+2*i;
for i:=1 to 200 do begin f1[i]:=dx;r1[i]:=dx;end;
k:=0;l:=0;n:=300;

repeat
setviewport(0,0,getmaxx,getmaxy,clipoff);
k:=k+1;i:=0;
if trunc(sqrt(k))=sqrt(k) then begin l:=k;n:=n-2;end;
                                     delay(0);
for i:=1 to n div 2 do putpixel(dx,dy+2*i,black);
for i:=1 to n div 2 do putpixel(dx,dy+2*i,red);

if k<>l then
if (k-l+1)div 2=(k-l+1)/2 then
begin f[(k-l+1)div 2]:=f[(k-l+1)div 2]+2;
putpixel(f[(k-l+1)div 2],m[(k-l+1)div 2],red); end
else
begin r[(k-l+1)div 2]:=r[(k-l+1)div 2]-2;
putpixel(r[(k-l+1)div 2],m[(k-l+1)div 2],red); end;

     clean(k);

if k<>l then
if (k-l+1)div 2=(k-l+1)/2 then
begin f1[(k-l+1)div 2]:=f1[(k-l+1)div 2]+2;
putpixel(f1[(k-l+1)div 2],m1[(k-l+1)div 2],black); end
else
begin r1[(k-l+1)div 2]:=r1[(k-l+1)div 2]-2;
putpixel(r1[(k-l+1)div 2],m1[(k-l+1)div 2],black); end else putpixel(dx,m1[trunc(sqrt(l))],black);

if k=21100 then for i:=1 to n-1 do putpixel(dx,dy+i,black);
until (k=21100)or(keypressed);
repeat until keypressed;
end.

Алгоритм у программы не очень мудреный, она просто сначала вычисляет координаты всех песчинок,и по правилу размещает их.
sand

Вот ссылки на на эту программу
DepositFiles.com

ifolder.ru


?

Log in