{> Cut here. FileName= SPHERE.PAS }
program sphiere;
uses graph,crt;
type vect=array[1..3] of real;
const
Il=1;
Ia=0.6;
ka=0.15;
kd=0.2;
ks=0.8;
st:byte=3;
rr:real=0;
aa=1;
l:vect=(-1,0,1);
s:vect=(0,0,1);
_s=50;
_r=30;
var
driver,mode : integer;
i,j,cyc : integer;
r,n : vect;
ys,xs : integer;
p : pointer;
size : word;
ex : boolean;
key : char;
min : real;
cfi,ca : real;
Procedure SetRGB(c,r,g,b:byte);
begin
port[$3c8]:=c;
port[$3c9]:=r;
port[$3c9]:=g;
port[$3c9]:=b
end;
Function w(c:real):real;
begin
w:=(c-0.5)*(c-0.5)/2+0.7
end;
Function Step(c:real;a:byte):real;
var
i:byte;
r:real;
begin
r:=1;
for i:=1 to a do r:=r*c;
step:=r
end;
Procedure sph(x,y,rad:integer;b:boolean);
var
i,j,q,c:integer;
len_l,len_r,len_s:real;
begin
len_l:=sqrt(sqr(l[1])+sqr(l[2])+sqr(l[3]));
if not b then rr:=0.8/abs(l[1]/len_l*x/640+l[2]/len_l*y/480+l[3]/len_l);
if rr>min then min:=rr;
for j:=-rad to rad do
begin
q:=trunc(sqrt(rad*rad-j*j));
for i:=-q to q do
begin
n[1]:=i/rad;
n[2]:=j/rad;
n[3]:=sqrt(rad*rad-i*i-j*j)/rad;
cfi:=(n[1]*l[1]+n[2]*l[2]+l[3]*n[3])/len_l;
if cfi<0 then cfi:=0;
for cyc:=1 to 3 do r[cyc]:=2*cfi*len_l*n[cyc]-l[cyc];{2*cfi}
len_r:=sqrt(r[1]*r[1]+r[2]*r[2]+r[3]*r[3]);
len_s:=sqrt(s[1]*s[1]+s[2]*s[2]+s[3]*s[3]);
ca:=(r[1]*s[1]+r[2]*s[2]+r[3]*s[3])/(len_r*len_s);
if (ca=1)and(l[3]=-r[3]) then ca:=0;
if ca<0 then ca:=0;
c:=trunc(63* (Il/(rr+aa)*(kd*cfi+ks*step(ca,st)) + Ia*ka));
putpixel(x+i,y+j,c);
end;
end;
end;
begin
driver:=InstallUserDriver('svga256', nil);
mode:=2;
InitGraph(driver, mode, '');
randomize;
ClearDevice;
for i:=1 to 63 do setRGB(i,i,i,i);
setcolor(5);
line(0,0,300,0);
xs:=100;ys:=100;
ex:=false;
size:=ImageSize(0,0,100,100);
GetMem( p, size);
repeat
GetImage( xs-_r, ys-_r, xs+_r, ys+_r, p^);
sph(xs,ys,_r,false);
key:=readkey;
if key=#0 then key:=readkey else
begin
ex:=(key=#27);
if key=#13 then
begin
for j:=-3 to 3 do begin
l[1]:=sqrt(9-j*j);
l[2]:=j;
sph(xs,ys,_r,true)
end;
for j:=2 downto -2 do begin
l[1]:=-sqrt(9-j*j);
l[2]:=j;
sph(xs,ys,_r,true)
end;
end;
end;
PutImage( xs-_r, ys-_r, p^, NormalPut);
case ord(key) of
75 : if xs>60 then dec(xs,_s);
77 : if xs<520 then inc(xs,_s);
80 : if ys<420 then inc(ys,_s);
72 : if ys>60 then dec(ys,_s)
end;
until ex;
closegraph
end.
|