This is a very primitive field with a quick gas cloud. (static)
Code: Select all
'nebula
Const back=Rgb(0,0,0)
Const f=0.03
Dim Shared As Integer xres,yres,mx,my
#macro setP(z)
p(0)=z
p(1)=Point(x,y-1,i)
p(2)=Point(x+1,y,i)
p(3)=Point(x,y+1,i)
p(4)=Point(x-1,y,i)
#endmacro
#macro setC
r+=Cast(Ubyte Ptr,@p(n))[2]
g+=Cast(Ubyte Ptr,@p(n))[1]
b+=Cast(Ubyte Ptr,@p(n))[0]
a+=Cast(Ubyte Ptr,@p(n))[3]
#endmacro
Sub inc(i As Long,Byref col As Ulong)
Static As Long k=1
Var r=Cast(Ubyte Ptr,@col)[2]
Var g=Cast(Ubyte Ptr,@col)[1]
Var b=Cast(Ubyte Ptr,@col)[0]
Var a=Cast(Ubyte Ptr,@col)[3]
Select Case i
Case 0
If r>255 Or r<0 Then k=-k
r+=k
col= Rgba(r,g,b,a)
Case 1
If g>255 Or g<0 Then k=-k
g+=k
col= Rgba(r,g,b,a)
Case 2
If b>255 Or b<0 Then k=-k
b+=k
col= Rgba(r,g,b,a)
Case 3
If a>255 Or a<0 Then k=-k
a+=k
col= Rgba(r,g,b,a)
End Select
End Sub
Sub merge(Byref c As Ulong,x As Long,y As Long,i As Any Ptr)
Static As Long p(0 To 4)
Var r=0,g=0,b=0,a=0,z=0
setP(c)
For n As Long=0 To 4
If p(n)<>back Then
setC
z+=1
End If
Next
If z Then c=Rgba(r\z,g\z,b\z,a\z)
End Sub
Sub filter(i As Any Ptr,n As Long)
Dim As Integer ix,iy
Imageinfo i,ix,iy
Dim As Long p(0 To 4)
Dim As Long k,x,y,r,g,b,a
For k =1 To n
For x =1 To ix-2
For y =1 To iy-2
r=0:g=0:b=0:a=0
setP(Point(x,y,i))
For n As Long=0 To 4
setC
Next
Pset i,(x,y),Rgba(r\5,g\5,b\5,a\5)
Next y
Next x
Next k
End Sub
Sub nebula(c As Ulong,x As Long,y As Long,lim As Long,i As Any Ptr)
#define Intrange(f,l) Int(Rnd*((l+1)-(f)))+(f)
#define offscreenx(n) n<10 Or n> (xres -10 )
#define offscreeny(n) n<10 Or n> (yres -10)
#macro increment
Select Case k
Case 1:inc(0,c)
Case 2:inc(1,c)
Case 3:inc(2,c)
Case 4:inc(3,c)
End Select
count+=1
#endmacro
Dim As Long count
Do
Var k=intrange(1,4)
Select Case k
Case 1
Var k=intrange(1,4)
increment
If offscreeny((y-1))Then y=intrange(10,760)
If Rnd<f Then merge(c,x,y-1,i)
Pset i,(x,y-1),c
y=y-1
Case 2
Var k=intrange(1,4)
increment
If offscreenx((x+1)) Then x=intrange(10,1000)
If Rnd<f Then merge(c,x+1,y,i)
Pset i,(x+1,y),c
x=x+1
Case 3
Var k=intrange(1,4)
increment
If offscreeny((y+1)) Then y=intrange(10,760)
If Rnd<f Then merge(c,x,y+1,i)
Pset i,(x,y+1),c
y=y+1
Case 4
Var k=intrange(1,4)
increment
If offscreenx((x-1)) Then x=intrange(10,1000)
If Rnd<f Then merge(c,x-1,y,i)
Pset i,(x-1,y),c
x=x-1
End Select
Loop Until count > lim
End Sub
' end nebula
#define lim 2000
#define Irange(f,l) Int(Rnd*((l+1)-(f)))+(f)
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define startrange Type(irange(-xres,xres*2),irange(-yres,yres*2),irange(0,10000))
Type Point
As Single x,y,z
End Type
Type Line
As Point p(1 To 2)
Declare Function perspective() As Line
Declare Sub advance(As Single)
Declare Sub Draw
Declare Constructor(As Point)
End Type
Constructor Line(x As Point)
p(1)=x:p(2)=p(1)
p(2).z=p(1).z+50
End Constructor
Function perspective(p As Point,eyepoint As Point) As Point
Dim As Single w=1+(p.z/eyepoint.z)
Return Type((p.x-eyepoint.x)/w+eyepoint.x,_
(p.y-eyepoint.y)/w+eyepoint.y,_
(p.z-eyepoint.z)/w+eyepoint.z)
End Function
Function line.perspective() As Line
Dim As Line x=Any
x.p(1)=..perspective(this.p(1),Type<Point>(mx,my,1000))
x.p(2)=..perspective(this.p(2),Type<Point>(mx,my,1000))
Return x
End Function
Sub line.advance(dz As Single)
p(1).z-=dz
p(2).z-=dz
End Sub
Sub line.draw
Static As Single max,min
If min>p(1).z Then min=p(1).z
If max<p(1).z Then max=p(1).z
Dim As Ubyte u=map(min,max,p(1).z,255,100)
Line(p(1).x,p(1).y)-(p(2).x,p(2).y),Rgba(255,255,255,u)
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
Static As Double timervalue,_lastsleeptime,t3,frames
Var t=Timer
frames+=1
If (t-t3)>=1 Then t3=t:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=T
Return sleeptime
End Function
'--------------------------
Dim As Line L(1 To lim)=Any
Randomize
Screeninfo xres,yres
Screenres .9*xres,.9*yres,32,,64
width .9*xres\8,.9*yres\16
Screeninfo xres,yres
Dim As Any Ptr i=Imagecreate(xres,yres,back)
Dim As Ulong c=Rgba(100,100,100,100)
nebula(c,xres\2,yres\2,2000000,i)
filter(i,4)
For n As Long=1 To lim
L(n)=Line(startrange)
Next
mx=xres\2:my=yres\2
Dim As Long fps
Do
Screenlock
Cls
Put(0,0),i,Pset
Draw String (1,1),"Framerate "&fps
For n As Long=1 To lim
L(n).advance(16)
Var tmp=L(n).perspective()
tmp.draw
If L(n).p(1).z<-950 Then L(n)=Line(startrange)
Next n
Screenunlock
Sleep regulate(80,fps)
Loop Until Inkey=Chr(27)
Imagedestroy i