Simple 3D Starfield build 2020-09-03

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
dodicat
Posts: 6726
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Simple 3D Starfield build 2020-09-01

Postby dodicat » Sep 03, 2020 10:48

Thanks dafhi.
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



 
UEZ
Posts: 635
Joined: May 05, 2017 19:59
Location: Germany

Re: Simple 3D Starfield build 2020-09-01

Postby UEZ » Sep 03, 2020 11:36

dodicat wrote:This is a very primitive field with a quick gas cloud. (static)

This looks also very beautiful - it is more discreet in the background. I like it.

Thanks for sharing it. :-)
dafhi
Posts: 1361
Joined: Jun 04, 2005 9:51

Re: Simple 3D Starfield build 2020-09-03

Postby dafhi » Sep 03, 2020 22:55

my defocus aadot doesn't play nicely with the other kids
[update: yes it does]

clevv new nebula .. without filter, technique becomes apparent

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 4 guests