Simple 3D Starfield build 2020-09-03

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Simple 3D Starfield build 2020-09-03

Post by UEZ »

Here another simple 3d starfield.

Code: Select all

'Coded by UEZ build 2020-08-27
#Include "fbgfx.bi"
Using FB

Randomize
Dim Shared As Boolean bFullscreen = False, bRotation = False

#Define Map(val, source_start, source_stop, dest_start, dest_stop)	((val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)

Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function

Dim Shared As Integer iW, iH
Dim As Integer x = 0, y = 0

#Ifdef __FB_WIN32__ 
	#Include "windows.bi"
	Dim As RECT tDesktop
	Dim As hwnd hHWND_Dt
	hHWND_Dt = FindWindow("Progman","Program Manager")
	GetWindowRect(hHWND_Dt, @tDesktop)
	x = tDesktop.left
	y = tDesktop.top
	iW = tDesktop.right + Abs(x)
	iH = tDesktop.bottom + Abs(y)
#Else
	ScreenControl GET_DESKTOP_SIZE, iW, iH 'not dpi aware!
#Endif

Dim As Long flags = GFX_FULLSCREEN Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_NO_FRAME
If bFullscreen = False Then
	iW = 1200
	iH = 800
	flags Xor= GFX_NO_FRAME
	flags Or= GFX_WINDOWED Or GFX_NO_SWITCH
End If

Dim Shared As Ushort iW2, iH2
iW2 = iW \ 2 : iH2 = iH \ 2


Screenres iW, iH, 32, 2, flags
Screenset 1, 0
If bFullscreen Then ScreenControl SET_WINDOW_POS, x, y

Type vec5
	As Single x, y, z, pz
End Type
	
Type Starfield
	Declare Constructor(quantity As Ulong = 19999)
	Declare Destructor()
	As Single speed
	As Double a
	As Ubyte maxRadius
	As Ulong n
	As vec5 star(Any)
	Declare Sub Init(quantity As Ulong)
	Declare Sub Anim()
End Type

Constructor Starfield(quantity As Ulong)
   This.Init(quantity)
End Constructor

Destructor Starfield()
End Destructor

Sub Starfield.Init(quantity As Ulong)
	This.a = Rnd()
	This.n = quantity + 1
	This.speed = 20
	This.maxRadius = 2
	ReDim This.star(quantity) As vec5
	
	For i As Ulong = 0 To Ubound(This.star)
		This.star(i).x = RandomRange(-iW, iW)
		This.star(i).y = RandomRange(-iH, iH)
		This.star(i).z = Rnd() * (iW + iH) / 2
		This.star(i).pz = This.star(i).z
	Next
End Sub

Sub Starfield.Anim()
	Dim As Single sx, sy, r, px, py, ppx, ppy, t1, t2
	Dim As Ubyte c
	Dim As Integer mx, my
	Getmouse(mx, my)
	This.speed = Map(my, 0, iH, 15, 0.5) 'set speed according to y mouse position -> top fastest, bottom slowest speed
	For i As Ulong = 0 To Ubound(This.star)
		If bRotation Then
			t1 = Sin(This.a / 180) * This.star(i).z
			t2 = Cos(This.a / 200) * This.star(i).z
			This.a += 0.00002
		End If
		sx = Map(This.star(i).x / This.star(i).z, 0, 1, 0, iW) + t1
		sy = Map(This.star(i).y / This.star(i).z, 0, 1, 0, iH) + t2
		
		px = Map(This.star(i).x / This.star(i).pz, 0, 1, 0, iW) + t1 'previous x
		py = Map(This.star(i).y / This.star(i).pz, 0, 1, 0, iH) + t2 'previous y
				
		r = Map(This.star(i).z, 0, iW, This.maxRadius, 0) 'radius
		c = Map(This.star(i).z, 0, (iW + iH) / 2, 255, 32) 'color value for greyscale
		
		ppx = iW2 + px
		ppy = iH2 + py
		
		If ppx > -r And ppx < iW And ppy > -r And ppy < iH Then
			Line(ppx, ppy) - (iW2 + sx, iH2 + sy), Rgba(255, 255, 255, c)
			Circle(iW2 + sx, iH2 + sy), r, Rgba(255, 255, 255, c),,,, F
		End If
		
		This.star(i).pz = This.star(i).z 'previous z
		This.star(i).z -= This.speed
		
		If This.star(i).z < 1 Then
			This.star(i).x = RandomRange(-iW, iW)
			This.star(i).y = RandomRange(-iH, iH)
			This.star(i).z = (iW + iH) / 2
			This.star(i).pz = This.star(i).z
		End If
	Next
End Sub

Dim As Starfield Stars = Starfield()

SetMouse iW2, Iif(bRotation, iH * 0.95, iH * 0.75)

Dim As Ushort iFps = 0, iFps_counter = 0
Dim As Integer w, rows, cols
w = Width
rows =  HiWord(w)
cols = LoWord(w)

Windowtitle("3D Starfield v0.60 coded by UEZ / Stars quantity: " & Stars.n)

Dim As Double fTimer = Timer

Do
	Cls
	Stars.Anim()
	If Timer - fTimer > 0.99 Then
		iFPS = iFps_counter
		iFps_counter = 0
		fTimer = Timer
	End If
	Locate rows - 2, 2
	? iFps & " fps"
	iFps_counter += 1
	Flip
	Sleep(1)
Loop Until Len(Inkey())
With Nebula:
Image

Code: Select all

'Coded by UEZ build 2020-09-03
'Additional code (Perling Noise and Nebula) by Tapio Vierros and Regulate by dodicat

#Include "fbgfx.bi"
Using FB

Randomize
Dim Shared As Boolean bFullscreen = False, bRotation = False, bNebula = True, bSpeedControl = False, bStaticNebula = True

If bRotation Then bNebula = False

'Perlin Noise
Declare Sub BuildNoiseTables(seed As Double = -1, num As Byte = 1)
Declare Sub BuildNoiseTable(seed As Double = -1, k As Byte = 0)

Const MAX_PERMS = 10
Dim Shared As UByte perm(512, 1 To MAX_PERMS)
Dim Shared As Double ms_grad4(256, 1 To MAX_PERMS)
Dim Shared As Double kkf(256)
For i As Integer = 0 To 255
	kkf(i) = -1.0f + 2.0f * (i / 255.0f)
Next

#Define BlendMul(a, b) (((a) * (b)) Shr 8)
#Define FADE(_t) (_t * _t * _t * (_t * (_t * 6 - 15) + 10))
#Define NLERP(_t, _a, _b) ((_a) + (_t) * ((_b) - (_a)))

'' Inititalize some permutation tables for different noises
Sub BuildNoiseTables(seed As Double = -1, num As Byte = 1)
    If seed <> -1 Then Randomize seed
    For k As Integer = 1 To num
        BuildNoiseTable(-1, k)
    Next k
End Sub

'' Buil a permutation table
Sub BuildNoiseTable(seed As Double = -1, k As Byte = 0)
    If seed <> -1 Then Randomize seed
    If k = 0 Then BuildNoiseTables(seed, MAX_PERMS): Exit Sub
    Dim As Integer i, j
    For i = 0 To 255
        perm(i, k) = i
    Next i

    For i = 0 To 255
        j = Rnd * 256
        Swap perm(i, k), perm(j, k)
    Next i

    For i = 0 To 255
        perm(i + 256, k) = perm(i, k)
    Next i
    
    For i As Integer = 0 To 255
        ms_grad4(i, k) = kkf(perm(i, k)) * 0.507f
    Next i  
End Sub

'' Perlin noise function
Function Noise(x As Double, y As Double, px As Double, py As Double, noiseId As Byte = 1) As Double
        Dim As Integer ix0, iy0, ix1, iy1
        Dim As Double fx0, fy0
        Dim As Double s, t, nx0, nx1, n0, n1
   
        ix0 = CInt(x - 0.5f)
        iy0 = CInt(y - 0.5f)
   
        fx0 = x - ix0
        fy0 = y - iy0
        If px < 1 Then px = 1
        If py < 1 Then py = 1
        ix1 = ((ix0 + 1) Mod px) And &hff
        iy1 = ((iy0 + 1) Mod py) And &hff
        ix0 = (ix0 Mod px) And &hff
        iy0 = (iy0 Mod py) And &hff
   
        t = FADE(fy0)
        s = FADE(fx0)
   
        nx0 = ms_grad4(perm(ix0 + perm(iy0, noiseId), noiseId), noiseId)
        nx1 = ms_grad4(perm(ix0 + perm(iy1, noiseId), noiseId), noiseId)
        n0 = NLERP( t, nx0, nx1 )
   
        nx0 = ms_grad4(perm(ix1 + perm(iy0, noiseId), noiseId), noiseId)
        nx1 = ms_grad4(perm(ix1 + perm(iy1, noiseId), noiseId), noiseId)
        n1 = NLERP(t, nx0, nx1)
   
        Return NLERP(s, n0, n1)
End Function

'' The actual Perlin noise function that sums octaves.
'' Call this.
'' Returns UByte.
Function Perlin(x As Double, y As Double, xsizemax As Double, ysizemax As Double, size As Double, noiseId As Byte = 1) As UByte
    ' size must be 2 ^ n
    Dim As Double value = 0.0, initialSize = size
   
    While(size >= 1)
        value += Noise(x / size, y / size, xsizemax / size, ysizemax / size, noiseId) * size
        size /= 2.0 '1.5
    Wend
   
    Return (128.0 * value / initialSize) + 127
End Function


'' Exponent filter for making clouds
Function ExpFilter(value As UByte, cover As Double, sharpness As Double) As UByte
    Dim As Double c = value - (255.0f - cover) '''''255
    If c < 0 Then c = 0
    value = 255.0f - (CDbl(sharpness^c) * 255.0f)
    Return CUByte(value)
End Function

If bStaticNebula Then 
		BuildNoiseTables(10, 10)
	Else
		BuildNoiseTables(Rnd() * Timer, 1 + Rnd() * 126)
end if


#Define csize 256 ' Color noise feature size, use power of 2 values
#Define PokePixel(_x, _y, _color)  Cptr(Ulong Ptr, imgData + _y * pitch + _x Shl 2)[0] = _color
#Define Map(val, source_start, source_stop, dest_start, dest_stop)	((val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)

Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function

Function Regulate(TargetFPS As Long, Byref fps As UShort) As Long 'by dodicat
	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 / TargetFPS) - t + timervalue) * 1000
	If sleeptime < 1 Then sleeptime = 1
	_lastsleeptime = sleeptime
	timervalue = t
	Return sleeptime
End Function

Dim Shared As Integer iW, iH
Dim As Integer x = 0, y = 0

#Ifdef __FB_WIN32__ 
	#Include "windows.bi"
	Dim As RECT tDesktop
	Dim As hwnd hHWND_Dt
	hHWND_Dt = FindWindow("Progman","Program Manager")
	GetWindowRect(hHWND_Dt, @tDesktop)
	x = tDesktop.left
	y = tDesktop.top
	iW = tDesktop.right + Abs(x)
	iH = tDesktop.bottom + Abs(y)
#Else
	ScreenControl GET_DESKTOP_SIZE, iW, iH 'not dpi aware!
#Endif

Dim As Long flags = GFX_FULLSCREEN Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_NO_FRAME
If bFullscreen = False Then
	iW = 1200
	iH = 800
	flags Xor= GFX_NO_FRAME
	flags Or= GFX_WINDOWED Or GFX_NO_SWITCH
End If

Dim Shared As Ushort iW2, iH2
iW2 = iW \ 2 : iH2 = iH \ 2


Screenres iW, iH, 32, 2, flags
Screenset 1, 0
If bFullscreen Then ScreenControl SET_WINDOW_POS, x, y

If bSpeedControl Then SetMouse iW2, iH * 0.95 'Iif(bRotation, iH * 0.95, iH * 0.85)

Type vec4
	As Single x, y, z, pz
End Type
	
Type Starfield
	Declare Constructor(quantity As Ulong = 19999)
	Declare Destructor()
	As Single speed
	As Double a
	As Ubyte maxRadius
	As Ulong n
	As vec4 star(Any)
	Declare Sub Init(quantity As Ulong)
	Declare Sub Anim()
End Type

Constructor Starfield(quantity As Ulong)
   This.Init(quantity)
End Constructor

Destructor Starfield()
End Destructor

Sub Starfield.Init(quantity As Ulong)
	This.speed = 2.0
	This.a = RandomRange(-2 * Acos(1), 2 * Acos(1))
	This.n = quantity + 1
	This.maxRadius = 2
	ReDim This.star(quantity) As vec4
	
	For i As Ulong = 0 To Ubound(This.star)
		This.star(i).x = RandomRange(-iW, iW)
		This.star(i).y = RandomRange(-iH, iH)
		This.star(i).z = Rnd() * (iW + iH) / 2
		This.star(i).pz = This.star(i).z
	Next
End Sub

Sub Starfield.Anim()
	Dim As Single sx, sy, r, px, py, ppx, ppy, t1 = 0, t2 = 0
	Dim As Ubyte c
	If bSpeedControl Then
		Dim As Integer mx, my
		Getmouse(mx, my)
		This.speed = Map(my, 0, iH, 25, 0.5) 'set speed according to y mouse position -> top fastest, bottom slowest speed
	End If
	For i As Ulong = 0 To Ubound(This.star)
		If bRotation Then
			t1 = Sin(This.a / 75) * This.star(i).z
			t2 = -Cos(This.a / 200) * This.star(i).z
			This.a += 0.00002
		End If
		sx = Map(This.star(i).x / This.star(i).z, 0, 1, 0, iW) + t1
		sy = Map(This.star(i).y / This.star(i).z, 0, 1, 0, iH) + t2
		
		px = Map(This.star(i).x / This.star(i).pz, 0, 1, 0, iW) + t1 'previous x
		py = Map(This.star(i).y / This.star(i).pz, 0, 1, 0, iH) + t2 'previous y
				
		r = Map(This.star(i).z, 0, (iW + iH) / 2, This.maxRadius, 0.25) 'radius
		c = Map(This.star(i).z, 0, (iW + iH) / 2, &hF8, &h08) 'color value for greyscale
		
		ppx = iW2 + px
		ppy = iH2 + py
		
		If ppx > -r And ppx < iW And ppy > -r And ppy < iH Then
			Line(ppx, ppy) - (iW2 + sx, iH2 + sy), Rgba(255, 255, 255, c)
			'If c > 210 Then Circle(iW2 + sx, iH2 + sy), r, Rgba(255, 255, 255, c),,,, F
			Circle(iW2 + sx, iH2 + sy), r, Rgba(255, 255, 255, c),,,, F
		End If
		
		This.star(i).pz = This.star(i).z 'previous z
		This.star(i).z -= This.speed
		
		If This.star(i).z < 1 Then
			This.star(i).x = RandomRange(-iW, iW)
			This.star(i).y = RandomRange(-iH, iH)
			This.star(i).z = (iW + iH) / 2
			This.star(i).pz = This.star(i).z
		End If
	Next
End Sub

Dim As Any Ptr pImageNebula = Imagecreate(iW, iH, &hFF000000, 32), imgData
Dim As Integer pitch
ImageInfo(pImageNebula, , , , pitch, imgData)
 
Union Col 
	As Ulong arbg
	Type
		As Ubyte b, g, r, a
	End Type
End Union

Dim As Col col
Dim As Ubyte ww

If bNebula Then
	'Create Nebula
	For x = 0 To iW - 1
		For y = 0 To iH - 1
			ww = Perlin(x, y, iW, iH, 256, 1)
			ww = ExpFilter(ww, 128, 0.99)
			col.r = BlendMul(Perlin(x, y, iW, iH, csize, 2), ww)
			col.g = BlendMul(Perlin(x, y, iW, iH, csize, 3), ww)
			col.b = BlendMul(Perlin(x, y, iW, iH, csize, 4), ww)
			col.a = &hE8
			If Rnd() < 0.50 Then 
				PSet pImageNebula, (x, y), Col.arbg	
				If Rnd() < 0.0003 Then
					PokePixel(CInt(Rnd() * (iW - 1)), CInt(Rnd() * (iH - 1)), Rgba(255, 255, 255, 255 * (0.50 + Rnd() * 0.33)))
					Circle pImageNebula, (Rnd() * (iW - 1), Rnd() * (iH - 1)), 0.50 + Rnd(), Rgba(255, 255, 255, 255 * (0.66 + Rnd() * 0.33)),,,, F
				end if						
			Else	
				If Rnd() < 0.00025 Then
					PokePixel(CInt(Rnd() * (iW - 1)), CInt(Rnd() * (iH - 1)), Rgba(255, 255, 255, &hFF))
				End if
				PSet pImageNebula, (x, y), Col.arbg
			end if
			'PokePixel(x, y, Col.arbg)
		Next
	Next
End If


Dim As Starfield Stars = Starfield()

Dim As Ushort iFps = 0

Windowtitle("3D Starfield v0.75 coded by UEZ / Stars quantity: " & Stars.n)

Dim As Double fTimer = Timer

Do
	Put (0, 0), pImageNebula, Pset 
	Stars.Anim()   
	Draw String(8, iH - 16), iFps & " fps", RGB(&hE0, &hE0, &hE0)
	Flip
	Sleep(Regulate(60, iFPS), 1)
Loop Until Len(Inkey())

Imagedestroy(pImageNebula)
Mouse controls flight speed (top = fastest, bottom = slowest).

Theoretically it should work also on Linux.

Edit1: slowed down move on rotation mode.
Edit2: change bRotation to False by default
Edit3: added additionally version with Nebula
Edit4: some small adjustments
Last edited by UEZ on Sep 03, 2020 14:44, edited 15 times in total.
David Watson
Posts: 56
Joined: May 15, 2013 16:48
Location: England

Re: Simple 3D Starfield build 2020-08-07

Post by David Watson »

Works on my Linux system. I'm getting 257 fps (and dizziness).
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Simple 3D Starfield build 2020-08-27

Post by UEZ »

David Watson wrote:Works on my Linux system. I'm getting 257 fps (and dizziness).
Thanks for testing. Just set bRotation = False to avoid vomit. ;-)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Simple 3D Starfield build 2020-08-27

Post by dodicat »

It's only a paper moon star.

Code: Select all



Type pt
    As Single x,y,z
End Type

Type angle
    As Single a(1 To 6)
    Declare Sub set(p As pt)
End Type

Sub angle.set(p As pt) 
    This= Type<angle>({Sin(p.x),Sin(p.y),Sin(p.z),Cos(p.x),Cos(p.y),Cos(p.z)}) 
End Sub

Type PaperStar
    As pt p(Any)
    As angle a
    As pt ctr
    As Ulong col
    As pt da
    As pt b
    Declare Constructor
    Declare Constructor(As Long,As Long,As Long,As Single,As pt,As Ulong,num As Long)
    Declare Sub fill(im As Any Ptr=0)
    Declare Function rotate() As PaperStar
End Type


#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
            While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J > begin Then fname(array(),begin,J)
            If I < Finish Then fname(array(),I,Finish)
        End Sub
        #endmacro  
        
        #define range(f,l) Rnd*((l)-(f))+(f)
        #define Irange(f,l) Int(Rnd*((l+1)-(f)))+(f)
        Function Rotate(c As pt,p As pt,a As angle,scale As pt=Type<pt>(1,1,1)) As pt
            Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
            Return Type<pt>((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)',p.col)
        End Function
        
        Function perspective(p As pt,eyepoint As pt) As pt
            Dim As Single   w=1+(p.z/eyepoint.z)
            Return Type<pt>((p.x-eyepoint.x)/w+eyepoint.x,_
            (p.y-eyepoint.y)/w+eyepoint.y,_
            (p.z-eyepoint.z)/w+eyepoint.z)',p.col)
        End Function 
        
        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
        
        Sub star(starX As Single,starY As Single,size As Single,num As Long=5,cut As Single=.4,s() As pt)
            Redim s(2*num)
            Var count=0,rad=0.0,_px=0.0,_py=0.0,pi=4*Atn(1)
            Var rot=0
            For z As Single=0+.28 +rot To 2*pi+.1+.28 +rot Step 2*pi/(2*num)
                count=count+1
                If count Mod 2=0 Then rad=size Else rad=cut*size
                _px=starx+rad*Cos(z)
                _py=stary+rad*Sin(z)
                s(count-1).x=_px
                s(count-1).y=_py
            Next z
        End Sub
        
        Function getctr(s As PaperStar) As pt
            Dim As Single cx,cy,cz
            Dim As Long sz=Ubound(s.p)+1
            For n As Long=Lbound(s.p) To Ubound(s.p)
                cx+=s.p(n).x
                cy+=s.p(n).y
                cz+=s.p(n).z
            Next
            Return Type(cx/sz,cy/sz,cz/sz)
        End Function
        
        
        Constructor PaperStar
        End Constructor
        
        Constructor PaperStar(x As Long,y As Long,z As Long,sz As Single,a As pt,colour As Ulong,n As Long)
        star(x,y,sz,n,range(.2,.6),p())
        ctr=getctr(This)
        For n As Long=Lbound(p) To Ubound(p)
            p(n).z=z
        Next
        da=a
        col=colour
        End Constructor
        
        Sub PaperStar.fill(im As Any Ptr=0)
            #define ub Ubound
            Dim As Long Sy=1e6,By=-1e6,i,j,y,k
            Dim As Single a(Ub(p)+1,1),dx,dy
            For i =0 To Ub(p)
                a(i,0)=p(i).x
                a(i,1)=p(i).y
                If Sy>p(i).y Then Sy=p(i).y
                If By<p(i).y Then By=p(i).y
            Next i
            Dim As Single xi(Ub(a,1)),S(Ub(a,1))
            a(Ub(a,1),0) = a(0,0)
            a(Ub(a,1),1) = a(0,1)
            For i=0 To Ub(a,1)-1
                dy=a(i+1,1)-a(i,1)
                dx=a(i+1,0)-a(i,0)
                If dy=0 Then S(i)=1
                If dx=0 Then S(i)=0
                If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
            Next i
            For y=Sy-1 To By+1
                k=0
                For i=0 To Ub(a,1)-1
                    If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
                    (a(i,1)>y Andalso a(i+1,1)<=y) Then
                    xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
                    k+=1
                End If
            Next i
            For j=0 To k-2
                For i=0 To k-2
                    If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
                Next i
            Next j
            For i = 0 To k - 2 Step 2
                Line im,(xi(i),y)-(xi(i+1)+1,y),col
            Next i
        Next y
    End Sub
    
    
    Function PaperStar.rotate() As PaperStar
        b.x+=da.x
        b.y+=da.y
        b.z+=da.z 
        a.set(b)
        Dim As PaperStar s=This
        ctr= getctr(s)
        For n As Long=Lbound(p) To Ubound(p)
            s.p(n)= ..Rotate(ctr,this.p(n),a)
            s.p(n)= perspective(s.p(n),Type(512,768\2,1500))
        Next
        Return s
    End Function
    
    #define rcolour Rgb(100+Rnd*155,100+Rnd*155,100+Rnd*155)
    Screen 20,32,,64
    Dim As PaperStar s(1 To 1000)
    For n As Long=1 To Ubound(s)
        Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
        s(n)=PaperStar(range(-100,1100),range(-100,800),Rnd*2400,15,tmp,rcolour,irange(3,9))
    Next
    
    SetQsort(PaperStar,QsortZ,down,.ctr.z)
    
    Dim As PaperStar z(1 To Ubound(s))
    Dim As Long fps
    #define onscreen(Q) Q.ctr.x>0 And Q.ctr.x<1024 And Q.ctr.y>0 And Q.ctr.y<768 'and Q.ctr.z <1800
    Do
        Screenlock
        Cls
        
        For n As Long=1 To Ubound(s)
            For m As Long=Lbound (s(n).p) To Ubound (s(n).p)
                s(n).p(m).z-=15
            Next m
            z(n)=s(n).rotate
            If s(n).ctr.z<-1480+40 Or  onscreen(s(n))=0 Then
                Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
                s(n)=PaperStar(range(-400,1400),range(-400,1200),900+Rnd*(2700),15,tmp,rcolour,irange(3,9))
            End If
        Next n
        
        QsortZ(z(),1,Ubound(z))
        
        For n As Long=1 To Ubound(z)
            If onscreen(z(n)) Then
                z(n).fill()
            End If
        Next n
        Draw String(10,10), "fps " &fps
        Screenunlock
        Sleep regulate(60,fps)
    Loop Until Inkey=Chr(27)
    
    Sleep
    
    
     
Roland Chastain
Posts: 993
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: Simple 3D Starfield build 2020-08-27

Post by Roland Chastain »

dodicat wrote:It's only a paper moon star.
Very pretty.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Simple 3D Starfield build 2020-08-27

Post by badidea »

dodicat wrote:It's only a paper moon star.
Like driving through heavy snowfall.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Simple 3D Starfield build 2020-08-27

Post by UEZ »

Nice dodicat.

I would add alpha channel to the color and make the objects on the z axis darken according to the distance. Far away = darkest, closest = brightest.


Btw, any idea how to create a Nebula background graphic generated by code?
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Simple 3D Starfield build 2020-08-27

Post by dodicat »

Alpha wasn't successful, the closest stars were a bit transparent,
I just darkened the far stars.
I made it a bit more gentle.

Code: Select all




Type pt
    As Single x,y,z
End Type

Type angle
    As Single a(1 To 6)
    Declare Sub set(p As pt)
End Type

Sub angle.set(p As pt) 
    This= Type<angle>({Sin(p.x),Sin(p.y),Sin(p.z),Cos(p.x),Cos(p.y),Cos(p.z)}) 
End Sub

Type PaperStar
    As pt p(Any)
    As angle a
    As pt ctr
    As Ulong col
    As pt da
    As pt b
    Declare Constructor
    Declare Constructor(As Long,As Long,As Long,As Single,As pt,As Ulong,num As Long)
    Declare Sub fill(im As Any Ptr=0,zval As Single=0)
    Declare Function rotate() As PaperStar
End Type


#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
            While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J > begin Then fname(array(),begin,J)
            If I < Finish Then fname(array(),I,Finish)
        End Sub
        #endmacro  
        
        #define range(f,l) Rnd*((l)-(f))+(f)
        #define Irange(f,l) Int(Rnd*((l+1)-(f)))+(f)
        #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
        Function Rotate(c As pt,p As pt,a As angle,scale As pt=Type<pt>(1,1,1)) As pt
            Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
            Return Type<pt>((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)',p.col)
        End Function
        
        Function perspective(p As pt,eyepoint As pt) As pt
            Dim As Single   w=1+(p.z/eyepoint.z)
            Return Type<pt>((p.x-eyepoint.x)/w+eyepoint.x,_
            (p.y-eyepoint.y)/w+eyepoint.y,_
            (p.z-eyepoint.z)/w+eyepoint.z)',p.col)
        End Function 
        
        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
        
        Sub star(starX As Single,starY As Single,size As Single,num As Long=5,cut As Single=.4,s() As pt)
            Redim s(2*num)
            Var count=0,rad=0.0,_px=0.0,_py=0.0,pi=4*Atn(1)
            Var rot=0
            For z As Single=0+.28 +rot To 2*pi+.1+.28 +rot Step 2*pi/(2*num)
                count=count+1
                If count Mod 2=0 Then rad=size Else rad=cut*size
                _px=starx+rad*Cos(z)
                _py=stary+rad*Sin(z)
                s(count-1).x=_px
                s(count-1).y=_py
            Next z
        End Sub
        
        Function getctr(s As PaperStar) As pt
            Dim As Single cx,cy,cz
            Dim As Long sz=Ubound(s.p)+1
            For n As Long=Lbound(s.p) To Ubound(s.p)
                cx+=s.p(n).x
                cy+=s.p(n).y
                cz+=s.p(n).z
            Next
            Return Type(cx/sz,cy/sz,cz/sz)
        End Function
        
        
        Constructor PaperStar
        End Constructor
        
        Constructor PaperStar(x As Long,y As Long,z As Long,sz As Single,a As pt,colour As Ulong,n As Long)
        star(x,y,sz,n,range(.2,.6),p())
        
        For n As Long=Lbound(p) To Ubound(p)
            p(n).z=z
        Next
        'ctr=getctr(This)
        da=a
        col=colour
        End Constructor
        
        Sub PaperStar.fill(im As Any Ptr=0,zval As Single=0)
            #define ub Ubound
            Static As Ubyte r,g,b
            r=Cast(Ubyte Ptr,@col)[2]
            g=Cast(Ubyte Ptr,@col)[1]
            b=Cast(Ubyte Ptr,@col)[0]
            Dim As Long Sy=1e6,By=-1e6,i,j,y,k
            Dim As Single a(Ub(p)+1,1),dx,dy
            For i =0 To Ub(p)
                a(i,0)=p(i).x
                a(i,1)=p(i).y
                If Sy>p(i).y Then Sy=p(i).y
                If By<p(i).y Then By=p(i).y
            Next i
            Dim As Single xi(Ub(a,1)),S(Ub(a,1))
            a(Ub(a,1),0) = a(0,0)
            a(Ub(a,1),1) = a(0,1)
            For i=0 To Ub(a,1)-1
                dy=a(i+1,1)-a(i,1)
                dx=a(i+1,0)-a(i,0)
                If dy=0 Then S(i)=1
                If dx=0 Then S(i)=0
                If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
            Next i
            For y=Sy-1 To By+1
                k=0
                For i=0 To Ub(a,1)-1
                    If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
                    (a(i,1)>y Andalso a(i+1,1)<=y) Then
                    xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
                    k+=1
                End If
            Next i
            For j=0 To k-2
                For i=0 To k-2
                    If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
                Next i
            Next j
            For i = 0 To k - 2 Step 2
                Line im,(xi(i),y)-(xi(i+1)+1,y),Rgb(zval*r,zval*g,zval*b)
            Next i
        Next y
    End Sub
    
    
    Function PaperStar.rotate() As PaperStar
        b.x+=da.x
        b.y+=da.y
        b.z+=da.z 
        a.set(b)
        Dim As PaperStar s=This
        ctr= getctr(s)
        For n As Long=Lbound(p) To Ubound(p)
            s.p(n)= ..Rotate(ctr,this.p(n),a)
            s.p(n)= perspective(s.p(n),Type(512,768\2,1500))
        Next
        Return s
    End Function
    
    #define rcolour Rgb(100+Rnd*155,100+Rnd*155,100+Rnd*155)
    Screen 20,32,,64
    Dim As Any Ptr i
    i=Imagecreate(1024,768,0)
    Sub cloud(x As Integer, y As Integer,length As Integer=100,Alpha As Integer=105, Zoom As Single = 0,im As Any Pointer=0)
        Dim As Integer rr=255
        Dim As Integer bb=255
        Dim As Integer gg=255
        Dim As Double pi=3.14159
        #define mp(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
        If Length<=1 Or Alpha<=1 Then Exit Sub
        Dim As Single rnded = -pi+Rnd*1*pi/2
        Dim As Single rnded2 = -pi+Rnd*-3*pi
        If Alpha<25 Then
            For i As Integer = 0 To 255-Alpha Step 100
                Var c=mp((0),(500),y,0,100)
                Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded*PI/3),y+Length/6+length*Sin(-pi/2+rnded*PI/3)),Rgba(Rr-c,(Gg-c)\2,255-(Bb-c),Alpha)
                Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded2*PI/3),y+Length/6+length*Sin(pi/2+rnded2*PI/3)),Rgba(255-(Rr-c),Gg-c,Bb-c,Alpha)
            Next
        End If
        cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded*PI/3),(Zoom/2)+y+length*Sin(-pi/2+rnded*PI/3),length/1.4,Alpha/1.2,Zoom,im)
        cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi/2+rnded2*PI/3),length/1.4,Alpha/1.2,Zoom,im)
        cloud(-(Zoom/2)+x+length*Cos(pi/3+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi+rnded2*PI/3),length/1.4,Alpha/2,Zoom,im)
    End Sub
    locate 20,20
    print "please wait . . ."
    cloud(600,240,140,50,0,i)
    
    Dim As Ulong p(0 To 5)'
    for k as long=1 to 5
    For x As Long=0 To 1023
        For y As Long=0 To 767
            Var r=0
            Var g=0
            Var b=0
            p(0)=Point(x,y,i)
            p(1)=Point(x,y-1,i)
            p(2)=Point(x+1,y,i)
            p(3)=Point(x+1,y+1,i)
            p(4)=Point(x,y+1,i)
            p(5)=Point(x-1,y,i)
            For n As Long=0 To 5
                r+=Cast(Ubyte Ptr,@p(n))[2]
                g+=Cast(Ubyte Ptr,@p(n))[1]
                b+=Cast(Ubyte Ptr,@p(n))[0]
            Next
            r/=6
            g/=6
            b/=6
            Pset i,(x,y),Rgb(r,g,b)
        Next y
    Next x
    next k
    
    Dim As PaperStar s(1 To 2000)
    For n As Long=1 To Ubound(s)
        Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
        s(n)=PaperStar(range(-1000,2024),range(-1000,1768),Rnd*3000*2,10,tmp,rcolour,irange(3,9))
    Next
    
    SetQsort(PaperStar,QsortZ,down,.ctr.z)
    
    Dim As PaperStar z(1 To Ubound(s))
    Dim As Long fps
    Dim As Single f
    #define onscreen(Q) Q.ctr.x>0 And Q.ctr.x<1024 And Q.ctr.y>0 And Q.ctr.y<768
    Dim As Long min=1000000,max=-1000000
    Do
        Screenlock
        Cls
        Locate 4
        Print min,max
        Put(0,0),i,Pset
        For n As Long=1 To Ubound(s)
            For m As Long=Lbound (s(n).p) To Ubound (s(n).p)
                s(n).p(m).z-=15
            Next m
            z(n)=s(n).rotate
            If min>z(n).ctr.z Then min=z(n).ctr.z
            If max<z(n).ctr.z Then max=z(n).ctr.z
            If s(n).ctr.z<-1480+40 Or  onscreen(s(n))=0 Then
                Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
                s(n)=PaperStar(range(-1000,2024),range(-1000,1768),3000+Rnd*(3000),10,tmp,rcolour,irange(3,9))
            End If
        Next n
        
        QsortZ(z(),1,Ubound(z))
        
        For n As Long=1 To Ubound(z)
            If onscreen(z(n)) Then
                f=map(min,max,z(n).ctr.z,1,.2)
                z(n).fill(,f)
            End If
        Next n
        Draw String(10,10), "fps " &fps
        Screenunlock
        Sleep regulate(60,fps)
    Loop Until Inkey=Chr(27)
    
    Sleep
    imagedestroy i
    
    
     
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

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

Post by UEZ »

Thanks dodicat. It looks better now. :-)

I added also a Nebula version. If you interested then have a look to the 1st post. ^^

Btw, I got a strange effect on the Circle function in line 259. It is not drawn as full closed circle but as half closed circle only although I didn't enter any value for the start / end angle value. Any idea?

Image
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

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

Post by dodicat »

Hi UEZ. You are overdrawing each right half of the circle row by row.
col.a = . . .
has no effect on direct pixel transparency, so you are completely overdrawing.
If you use pset then you can see partially the other half due to the alpha taking effect.
Your nebula looks perfect without the half moons anyway.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

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

Post by UEZ »

dodicat wrote:Hi UEZ. You are overdrawing each right half of the circle row by row.
col.a = . . .
has no effect on direct pixel transparency, so you are completely overdrawing.
If you use pset then you can see partially the other half due to the alpha taking effect.
Your nebula looks perfect without the half moons anyway.

Of course, when I put this into the two loops. Image

I wanted to put some fixed stars onto the nebula...

I updated the code in the first post.
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

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

Post by dafhi »

done a few starfields myself. nebula effect looks amazing!

might have a go with starfield later using my depth-of-field sim. [edit - done!]

Code: Select all

' depth-of-field effect - 2017 Nov 15 - by dafhi
'original demo by UEZ - https://www.freebasic.net/forum/viewtopic.php?f=7&t=28778

' -- changes
' maxRadius to single
' starfield .init & .anim

' -- additions
' imagevars & aadot
' initialization after screenres

type imagevars '2017 Oct 10 - by dafhi
  as integer            w,h,bpp,bypp,pitch,rate,  wm, hm, pitchBy 'helpers
  as any ptr            im, pixels
  as ulong ptr          p32
  as string             driver_name
  declare sub           get_info(im as any ptr=0)
  declare               destructor
  as single             midx, midy, diagonal '2017 Oct 10
end type

Destructor.imagevars
  If ImageInfo(im) = 0 Then ImageDestroy im:  im=0
End Destructor

sub imagevars.get_info(im as any ptr)
  if im=0 then
    ScreenInfo w,h, bpp, bypp, pitch, rate, driver_name
    pixels=screenptr
  elseif Imageinfo(im)=0 then
    ImageInfo im, w, h, bypp, pitch, pixels
    this.im = im:  bpp = bypp * 8
  endif: wm=w-1: hm=h-1:  pitchBy=pitch\bypp:  p32=pixels
  midx=w/2: midy=h/2:  diagonal = sqr(w*w+h*h)
end sub


#Macro Alpha256(ret,back, fore, a256) '2017 Mar 26
  ret=((_
  (fore And &Hff00ff) * a256 + _
  (back And &Hff00ff) * (256-a256) + &H800080) And &Hff00ff00 Or (_
  (fore And &H00ff00) * a256 + _
  (back And &H00ff00) * (256-a256) + &H008000) And &H00ff0000) Shr 8
#EndMacro

#define flr(x)        (((x)*2.0-0.5)shr 1)


type DotVars          '2017 Nov 15 - by dafhi
  union
    Type:  As UByte   b,g,r,a
    End Type
    As ULong          col
  end union
  as single           x,y,z
  as single           rad=1, slope=1
End Type

type tView3D
  as single           eyepiece_diam = 1
  as single           FL = 20
End Type


type AaDot            '2017 Nov 15 - by dafhi
  as dotvars          dot
  as dotvars ptr      p
  as tView3D          vie
  declare sub         render_target(byref buf as imagevars ptr)
  declare sub         draw(x as single=0, y as single=0, col as ulong = -1)
  declare sub         defocus_draw(byref p as dotvars ptr)
  declare constructor(byref buf as imagevars ptr=0)
 private:
  as dotvars          q
  as single           dy,dxLeft,salpha,cone_h,coneSq,sq,salpha0,slope
  as long             x0,y0,x1,y1,alph,alpha_max
  as imagevars ptr    im
  as single           r_expan, z_prime, rad0
end type

constructor.AaDot(byref buf as imagevars ptr=0):  dot.col = -1
  p=@dot:  if buf<>0 then im=buf
end constructor

sub AaDot.render_target(byref buf as imagevars ptr):  im = buf
end sub

sub AaDot.draw(x as single, y as single, col as ulong)

  dim as long y0=(y-p->rad):  if y0<0 then y0=0
  dim as long y1=(y+p->rad):  if y1>im->hm then y1=im->hm
 
  if y1<y0 then exit sub '2017 Nov 10
 
  salpha0=(col shr 24)/255:  alpha_max=salpha0*256
  slope = p->slope
 
  '' slope = 1 .. 1 pixel aa edge
  '' slope = 2 .. 1/2 pixel (sharp)
  '' slope = 1/p->rad .. max blur
  '' slope < 1/p->rad .. rendering artifact
 
  'sq=1/p->rad                   '' clamp prevents artifact
  'slope=iif(slope<sq,sq,slope)  ''
 
  cone_h=slope*(p->rad+.5)     'pre-inverted aadot imagined as cone \/
  coneSq=cone_h*cone_h    'avoid sqr() at blit corners
  sq=(cone_h-1)*(cone_h-1)'avoid sqr() in dot center at max brightness
  dim as long x0=(x-p->rad):  if x0<0 then x0=0
  dim as long x1=(x+p->rad):  if x1>im->wm then x1=im->wm

  dy=(y0-y)*slope: dxLeft=(x0-x)*slope
  for py as long ptr = @im->p32[ y0*im->pitchBy ] to @im->p32[ y1*im->pitchBy ] step im->pitchBy
    dim as single dx=dxleft, dySq=dy*dy
    for px as ulong ptr = @py[x0] to @py[x1]
      salpha = dx*dx+dySq
      if salpha<sq then
          Alpha256(*px,*px,col,alpha_max)
      elseif salpha<=coneSq then
          alph=(cone_h-sqr(salpha))*alpha_max
          Alpha256(*px,*px,col,alph)
      endif:  dx+=slope
    next: dy+=slope
  next

end sub

sub AaDot.defocus_draw(byref pdv as dotvars ptr)
  p = @q '' internal variable q final reault

  with *pdv
    r_expan = vie.eyepiece_diam * abs((vie.fl - .z) / vie.fl)
    q.rad = .rad + r_expan
    q.slope = .slope / q.rad
    q.col = .col
    q.a = -.5 + 256 * .rad * .rad / (q.rad * q.rad)
    draw .x, .y, q.col
  End With

End Sub

dim shared as aadot  aa


#Include "fbgfx.bi"
Using FB

Randomize
Dim Shared As Boolean bFullscreen = False, bRotation = False

#Define Map(val, source_start, source_stop, dest_start, dest_stop)   ((val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)

Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function

Dim Shared As Integer iW, iH
Dim As Integer x = 0, y = 0

#Ifdef __FB_WIN32__
   #Include "windows.bi"
   Dim As RECT tDesktop
   Dim As hwnd hHWND_Dt
   hHWND_Dt = FindWindow("Progman","Program Manager")
   GetWindowRect(hHWND_Dt, @tDesktop)
   x = tDesktop.left
   y = tDesktop.top
   iW = tDesktop.right + Abs(x)
   iH = tDesktop.bottom + Abs(y)
#Else
   ScreenControl GET_DESKTOP_SIZE, iW, iH 'not dpi aware!
#Endif

Dim As Long flags = GFX_FULLSCREEN Or GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_NO_FRAME
If bFullscreen = False Then
   iW = 1200
   iH = 800
   flags Xor= GFX_NO_FRAME
   flags Or= GFX_WINDOWED Or GFX_NO_SWITCH
End If

Dim Shared As Ushort iW2, iH2
iW2 = iW \ 2 : iH2 = iH \ 2


Screenres iW, iH, 32, 2, flags
Screenset 1, 0
If bFullscreen Then ScreenControl SET_WINDOW_POS, x, y

SetMouse iW2, iH * 0.95 'Iif(bRotation, iH * 0.95, iH * 0.85)


''
  dim as imagevars  buf:  buf.get_info
  aa.render_target @buf


Type vec4
   As Single x, y, z, pz
End Type
   
Type Starfield
   Declare Constructor(quantity As Ulong = 19999)
   Declare Destructor()
   As Single speed
   As Double a
   As single maxRadius
   As Ulong n
   As vec4 star(Any)
   Declare Sub Init(quantity As Ulong)
   Declare Sub Anim()
End Type

Constructor Starfield(quantity As Ulong)
   This.Init(quantity)
End Constructor

Destructor Starfield()
End Destructor

Sub Starfield.Init(quantity As Ulong)
   This.a = RandomRange(-2 * Acos(1), 2 * Acos(1))
   This.n = quantity + 1
   This.maxRadius = 1
   ReDim This.star(quantity) As vec4
   
   For i As Ulong = 0 To Ubound(This.star)
      This.star(i).x = RandomRange(-iW, iW)
      This.star(i).y = RandomRange(-iH, iH)
      This.star(i).z = Rnd() * (iW + iH) / 2
      This.star(i).pz = This.star(i).z
   Next
   
   aa.vie.fl = 200 '' focal length ~ average dot depth
   
   aa.vie.eyepiece_diam = .5
   
   aa.dot.slope = 4
   aa.dot.col = -1
End Sub

Sub Starfield.Anim()
   Dim As Single sx, sy, r, px, py, ppx, ppy, t1, t2
   Dim As Ubyte c
   Dim As Integer mx, my
   Getmouse(mx, my)
   This.speed = Map(my, 0, iH, 25, 0.5) 'set speed according to y mouse position -> top fastest, bottom slowest speed
   For i As Ulong = 0 To Ubound(This.star)
      If bRotation Then
         t1 = Sin(This.a / 75) * This.star(i).z
         t2 = -Cos(This.a / 200) * This.star(i).z
         This.a += 0.00002
      End If
      sx = Map(This.star(i).x / This.star(i).z, 0, 1, 0, iW) + t1
      sy = Map(This.star(i).y / This.star(i).z, 0, 1, 0, iH) + t2
     
      px = Map(This.star(i).x / This.star(i).pz, 0, 1, 0, iW) + t1 'previous x
      py = Map(This.star(i).y / This.star(i).pz, 0, 1, 0, iH) + t2 'previous y
           
      ppx = iW2 + px
      ppy = iH2 + py
     
'      If ppx > -r And ppx < iW And ppy > -r And ppy < iH Then
          c = Map(This.star(i).z, 0, (iW + iH) / 2, &hF0, &h10) 'color value for greyscale
          aa.dot.rad = Map(This.star(i).z, 0, iW, This.maxRadius, 0) 'radius
     
          aa.dot.x = sx + iW2
          aa.dot.y = sy + iH2
          aa.dot.z = star(i).z
          aa.dot.col = -1'rgba(255,255,255,c)
          aa.defocus_draw @aa.dot
         'Line(ppx, ppy) - (iW2 + sx, iH2 + sy), Rgba(255, 255, 255, c)
         'Circle(iW2 + sx, iH2 + sy), r, Rgba(255, 255, 255, c),,,, F
'      End If
     
      This.star(i).pz = This.star(i).z 'previous z
      This.star(i).z -= This.speed
     
      If This.star(i).z < 1 Then
         This.star(i).x = RandomRange(-iW, iW)
         This.star(i).y = RandomRange(-iH, iH)
         This.star(i).z = (iW + iH) / 2
         This.star(i).pz = This.star(i).z
      End If
   Next
End Sub


'Perlin Noise
Declare Sub BuildNoiseTables(seed As Double = -1, num As Byte = 1)
Declare Sub BuildNoiseTable(seed As Double = -1, k As Byte = 0)

Const MAX_PERMS = 10
Dim Shared As UByte perm(512, 1 To MAX_PERMS)
Dim Shared As Double ms_grad4(256, 1 To MAX_PERMS)
Dim Shared As Double kkf(256)
For i As Integer = 0 To 255
   kkf(i) = -1.0f + 2.0f * (i / 255.0f)
Next

#Define BlendMul(a, b) (((a) * (b)) Shr 8)
#Define FADE(_t) (_t * _t * _t * (_t * (_t * 6 - 15) + 10))
#Define NLERP(_t, _a, _b) ((_a) + (_t) * ((_b) - (_a)))

'' Inititalize some permutation tables for different noises
Sub BuildNoiseTables(seed As Double = -1, num As Byte = 1)
    If seed <> -1 Then Randomize seed
    For k As Integer = 1 To num
        BuildNoiseTable(-1, k)
    Next k
End Sub

'' Buil a permutation table
Sub BuildNoiseTable(seed As Double = -1, k As Byte = 0)
    If seed <> -1 Then Randomize seed
    If k = 0 Then BuildNoiseTables(seed, MAX_PERMS): Exit Sub
    Dim As Integer i, j
    For i = 0 To 255
        perm(i, k) = i
    Next i

    For i = 0 To 255
        j = Rnd * 256
        Swap perm(i, k), perm(j, k)
    Next i

    For i = 0 To 255
        perm(i + 256, k) = perm(i, k)
    Next i
   
    For i As Integer = 0 To 255
        ms_grad4(i, k) = kkf(perm(i, k)) * 0.507f
    Next i
End Sub

'' Perlin noise function
Function Noise(x As Double, y As Double, px As Double, py As Double, noiseId As Byte = 1) As Double
        Dim As Integer ix0, iy0, ix1, iy1
        Dim As Double fx0, fy0
        Dim As Double s, t, nx0, nx1, n0, n1
   
        ix0 = CInt(x - 0.5f)
        iy0 = CInt(y - 0.5f)
   
        fx0 = x - ix0
        fy0 = y - iy0
        If px < 1 Then px = 1
        If py < 1 Then py = 1
        ix1 = ((ix0 + 1) Mod px) And &hff
        iy1 = ((iy0 + 1) Mod py) And &hff
        ix0 = (ix0 Mod px) And &hff
        iy0 = (iy0 Mod py) And &hff
   
        t = FADE(fy0)
        s = FADE(fx0)
   
        nx0 = ms_grad4(perm(ix0 + perm(iy0, noiseId), noiseId), noiseId)
        nx1 = ms_grad4(perm(ix0 + perm(iy1, noiseId), noiseId), noiseId)
        n0 = NLERP( t, nx0, nx1 )
   
        nx0 = ms_grad4(perm(ix1 + perm(iy0, noiseId), noiseId), noiseId)
        nx1 = ms_grad4(perm(ix1 + perm(iy1, noiseId), noiseId), noiseId)
        n1 = NLERP(t, nx0, nx1)
   
        Return NLERP(s, n0, n1)
End Function

'' The actual Perlin noise function that sums octaves.
'' Call this.
'' Returns UByte.
Function Perlin(x As Double, y As Double, xsizemax As Double, ysizemax As Double, size As Double, noiseId As Byte = 1) As UByte
    ' size must be 2 ^ n
    Dim As Double value = 0.0, initialSize = size
   
    While(size >= 1)
        value += Noise(x / size, y / size, xsizemax / size, ysizemax / size, noiseId) * size
        size /= 2.0 '1.5
    Wend
   
    Return (128.0 * value / initialSize) + 127
End Function


'' Exponent filter for making clouds
Function ExpFilter(value As UByte, cover As Double, sharpness As Double) As UByte
    Dim As Double c = value - (255.0f - cover) '''''255
    If c < 0 Then c = 0
    value = 255.0f - (CDbl(sharpness^c) * 255.0f)
    Return CUByte(value)
End Function

BuildNoiseTables(Timer, 5)
#Define csize 256 ' Color noise feature size, use power of 2 values
#Define PokePixel(_x, _y, _color)  Cptr(Ulong Ptr, imgData + _y * pitch + _x Shl 2)[0] = _color

Dim As Any Ptr pImageNebula = Imagecreate(iW, iH, &hFF000000, 32), imgData
Dim As Integer pitch
ImageInfo(pImageNebula, , , , pitch, imgData)
 
Union Col
   As Ulong arbg
   Type
      As Ubyte b, g, r, a
   End Type
End Union

Dim As Col col
Dim As Ubyte ww

'Create Nebula
#if 1
For x = 0 To iW - 1
   For y = 0 To iH - 1
      ww = Perlin(x, y, iW, iH, 256, 1)
      ww = ExpFilter(ww, 160, 0.99)
      col.r = BlendMul(Perlin(x, y, iW, iH, csize, 2), ww)
      col.g = BlendMul(Perlin(x, y, iW, iH, csize, 3), ww)
      col.b = BlendMul(Perlin(x, y, iW, iH, csize, 4), ww)
      PokePixel(x, y, Col.arbg)
   Next
Next

For x = 0 To 1000
   If Rnd() < 0.05 Then
      'PokePixel(x, y, Rgba(255, 255, 255, 255 * (0.33 + Rnd() * 0.33)))
      Circle pImageNebula, (Rnd() * iW , Rnd() * iH), 0.5 + Rnd(), Rgba(255, 255, 255, 255 * (0.50 + Rnd() * 0.25)),,,, F
   End If
Next
#endif

Dim As Starfield Stars = Starfield(15000 - 1)

Dim As Ushort iFps = 0, iFps_counter = 0

Windowtitle("3D Starfield v0.70 coded by UEZ / Stars quantity: " & Stars.n)

Dim As Double fTimer = Timer

Do
   Put (0, 0), pImageNebula, Pset
   Stars.Anim()   
   Draw String(8, iH - 16), iFps & " fps", RGB(&hE0, &hE0, &hE0)
   Flip
   
   If Timer - fTimer > 0.99 Then
      iFPS = iFps_counter
      iFps_counter = 0
      fTimer = Timer
   End If

   iFps_counter += 1
   
   Sleep(1)
Loop Until Len(Inkey())

Imagedestroy(pImageNebula)
Last edited by dafhi on Sep 04, 2020 9:06, edited 5 times in total.
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

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

Post by UEZ »

dafhi wrote:done a few starfields myself. nebula effect looks amazing!

might have a go with starfield later using my depth-of-field sim
Looks very nice. I like this effect and I'm fascinated looking to this effect in the demos.
For example: Rhodium by Virgill & Alcatraz -> https://www.youtube.com/watch?v=sSHnZMhjStI

Thanks for sharing.
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

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

Post by dafhi »

Code: Select all

 with a slightly more intuitive approach

cool demo.  weak intel gpu w/ Pixar quality effects
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

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

Post by UEZ »

dafhi wrote:

Code: Select all

 with a slightly more intuitive approach

cool demo.  weak intel gpu w/ Pixar quality effects[/quote]

Very nice, if I increase the size of pixels it looks better. It looks like a snowfall whereas the view is from bottom. 
Cool.
Post Reply