Code: Select all
Type vector3d
As Single x,y,z
End Type
#define V3 vector3D
Type angle
As Single a(1 To 6)
declare sub set(as V3)
End Type
sub angle.set(a as V3)
this=Type({Sin(a.x),Sin(a.y),Sin(a.z),Cos(a.x),Cos(a.y),Cos(a.z)})
end sub
#define vct Type<vector3d>
Function Rotate3D(c As V3,p As V3,a As angle,scale As V3=type(1,1,1)) As V3
Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
Return type((scale.x)*((a.a(5)*a.a(6))*dx+(-a.a(4)*a.a(3)+a.a(1)*a.a(2)*a.a(6))*dy+(a.a(1)*a.a(3)+a.a(4)*a.a(2)*a.a(6))*dz)+c.x,_
(scale.y)*((a.a(5)*a.a(3))*dx+(a.a(4)*a.a(6)+a.a(1)*a.a(2)*a.a(3))*dy+(-a.a(1)*a.a(6)+a.a(4)*a.a(2)*a.a(3))*dz)+c.y,_
(scale.z)*((-a.a(2))*dx+(a.a(1)*a.a(5))*dy+(a.a(4)*a.a(5))*dz)+c.z)
End Function
Function apply_perspective(p As vector3d,eyepoint As vector3d) As vector3d
Dim As Single w=1+(p.z/eyepoint.z)
If w=0 Then w=1e-20
Return Type<vector3d>((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z)
End Function
'====================== End of rotator and perspective ======================================
#macro incircle(cx,cy,r,mx,my,a)
iif(a<=1,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r))
#endmacro
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))
#macro star(starx,stary,size,col,rot)
Scope
Var count=0,rad=0.0,_px=0.0,_py=0.0,pi=4*atn(1),prime=rgb(255,254,253)
for x as integer=1 to 2
For z As Single=0+.28 +rot To 2*pi+.1+.28 +rot Step 2*pi/10
count=count+1
If count Mod 2=0 Then rad=size Else rad=.4*size
_px=starx+rad*Cos(z)
_py=stary+rad*Sin(z)
If count=1 Then Pset (_px,_py)Else Line -(_px,_py),prime
Next z
Paint (starx,stary),prime,prime
count=0:prime=col
next x
End Scope
#endmacro
Function Regulate(Byval MyFps As long,Byref fps As long) As long
Static As Double timervalue,lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Dim As Integer number=10000
Dim As Integer xres,yres
Screen 20,32
Screeninfo xres,yres
Color , Rgb(0,0,20)
Redim As vector3d array(0)
Redim As Ulong colour(0)
For n As Integer=1 To number step 4
Var xpos=xres\2+(200-n/100)*cos(n/100)+rnd*5-rnd*5
Var ypos=yres\2+(200-n/100)*sin(n/100)+rnd*5-rnd*5
var zz=map(1,number,n,-1,1)
Var zpos=(10000)*cos(zz*1.5)
If incircle(xres/2,yres/2,.4*yres,xpos,ypos,(1+(n/(.5*number)))) Then
Redim Preserve array(1 To Ubound(array)+1)
array(Ubound(array))=vct(xpos,ypos,zpos)
Redim Preserve colour(1 To Ubound(colour)+1)
colour(Ubound(colour))=Rgb(IntRange(150,255),IntRange(150,255),IntRange(150,255))
End If
Next n
Dim As vector3d centre=vct(xres/2,yres/2,0)
Dim As vector3d eyepoint=vct(xres/2,yres/2,1000)
Dim As angle ang
dim as v3 da
Dim As long fps
Do
if multikey(77) then eyepoint.x=eyepoint.x+5 'r
if multikey(75) then eyepoint.x=eyepoint.x-5 'l
if multikey(72) then eyepoint.y=eyepoint.y-5 'up
if multikey(80) then eyepoint.y=eyepoint.y+5 'down
if eyepoint.y<0 then eyepoint.y=0
if eyepoint.y>yres then eyepoint.y=yres
if eyepoint.x<0 then eyepoint.x=0
if eyepoint.x>xres then eyepoint.x=xres
da.z=da.z+.01
ang.set(da)
Screenlock
Cls
For n As Integer=1 To Ubound(array)
array(n).z=array(n).z-4
Var temp=rotate3d(centre,array(n),ang,vct(1,1,1))
temp=apply_perspective(temp,eyepoint)
Var radius=map(0,-1000,temp.z,1,2.5)
star(temp.x,temp.y,radius,colour(n),20*da.z)
If array(n).z<-1000 Then array(n).z=1500
Next n
Draw String(20,20),"Frames per second = " & fps
Screenunlock
Sleep regulate(65,fps),1
Loop Until inkey=chr(27)
