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())
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)
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