Информационный сервер для программистов: Исходники со всего света. Паскальные исходники со всего света
  Powered by Поисковый сервер Яndex: Найдется ВСЁ!
На Главную Pascal Форум Информер Страны мира
   Demo Making    >>    sphere
   
 
 Sphere Drawing Sample with SVGA BGI Graphics  Unknown 25.09.1997

Простейшая программа, демонстрирующая алгоритм рисования сферы с затенением и световым бликом. Сферу можно перемещать по экрану и "крутиться" на месте.



6k 
 

  {> 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.