Thought I'd share some otherwise useless eye candy for QB64 users.
Code:
_TITLE "OldMoses' 3D StarField (+ & - speed) (left/right arrows turn)"
a& = _NEWIMAGE(600, 600, 32)
SCREEN a&
DO: LOOP UNTIL _SCREENEXISTS
_SCREENMOVE 50, 50
TYPE star ' define the star data type
x AS INTEGER
y AS INTEGER
z AS INTEGER
r AS INTEGER
g AS INTEGER
b AS INTEGER
xa AS INTEGER
ya AS INTEGER
END TYPE
DIM SHARED max AS INTEGER: max = 500
DIM SHARED vprt AS INTEGER: vprt = 600 ' set the viewport setback from viewer's eye
DIM SHARED p(max) AS star ' dimension the star data array
DIM SHARED speed AS INTEGER: speed = 2 ' warp factor
DIM SHARED xch AS _BYTE
DIM SHARED ych AS _BYTE
PopVoid ' OldMoses said "Let there be light" and the universe was, is and ever shall be
WINDOW (-300, 300)-(300, -300) ' create viewport window, Cap'n Kirk spends his days staring at this
DO ' draw the stars
x$ = INKEY$
IF x$ = "" THEN
xch = 0: ych = 0
END IF
IF x$ = CHR$(43) THEN speed = speed + 1
IF x$ = CHR$(45) THEN speed = speed - 1
IF x$ = CHR$(0) + CHR$(75) THEN xch = 1
IF x$ = CHR$(0) + CHR$(77) THEN xch = -1
'IF x$ = CHR$(0) + CHR$(72) THEN ych = 1
'IF x$ = CHR$(0) + CHR$(80) THEN ych = -1
CLS
FOR x = 1 TO max ' iterate through all stars
dst = Pythagorus(p(x)) ' distance to star
p(x).x = p(x).x + SinCalc(p(x).z, xch * 0.3)
'p(x).y = p(x).y + CosCalc(p(x).z, ych * 0.3) ' <<<this just doesn't work
p(x).xa = p(x).x / dst * vprt ' get relative screen position from absolute position for x & y
p(x).ya = p(x).y / dst * vprt
IF ABS(p(x).xa) < 301 AND ABS(p(x).ya) < 301 THEN ' place the star if within the viewport
fdf& = (dst - 12952) / 8
IF fdf& < 0 THEN fdf& = 0
SELECT CASE dst
CASE IS > 7500
PSET (p(x).xa, p(x).ya), _RGBA32(p(x).r, p(x).g, p(x).b, 255 - fdf&)
CASE ELSE
FCirc p(x).xa, p(x).ya, 1, _RGBA32(p(x).r, p(x).g, p(x).b, 255)
END SELECT
END IF
p(x).z = p(x).z - speed ' move the star closer to the viewer
IF speed < 0 THEN
IF p(x).z > 15000 THEN ReplaceStar x, 0
ELSE
IF p(x).z < 0 THEN ReplaceStar x, 15000 ' add new stars as existing ones go behind the viewer
END IF
NEXT x
_DISPLAY ' eliminate screen flicker
_LIMIT 500 ' smooth out the action
LOOP UNTIL _KEYDOWN(27)
SUB PopVoid ' Do an initial population of stars
FOR x = 1 TO max ' place a 'max' # of stars randomly in a 3D space
RANDOMIZE TIMER
p(x).x = INT(RND * 15000) - 7500
p(x).y = INT(RND * 15000) - 7500
p(x).z = INT(RND * 15000) + 1
t% = INT(RND * 110) - 55
ch = INT(RND * 6)
IF ch < 4 THEN
p(x).r = 200 + t%: p(x).b = 200 - t%
ELSE
p(x).r = 200 - t%: p(x).b = 200 + t%
END IF
p(x).g = 200
NEXT x
END SUB 'PopVoid
FUNCTION Pythagorus (var1 AS star)
horizontal = _HYPOT(ABS(var1.x), ABS(var1.y)) ' Use to find distance between star and origin (viewer)
Pythagorus = _HYPOT(horizontal, ABS(var1.z))
END FUNCTION 'Pythagorus
SUB ReplaceStar (var AS INTEGER, insert AS INTEGER) ' This replaces any star that goes behind the viewer
RANDOMIZE TIMER
p(var).x = INT(RND * 15000) - 7500 ' New x,y,z but keep old color for simplicity sake
p(var).y = INT(RND * 15000) - 7500
p(var).z = insert
END SUB 'ReplaceStar
FUNCTION SinCalc (var1 AS _INTEGER64, var2 AS SINGLE)
'Polar coordinate X finder
'used to find X coordinate of a speed/distance (var1) and heading/azimuth (var2)
SinCalc = var1 * SIN(_D2R(var2))
END FUNCTION 'SinCalc
FUNCTION CosCalc (var1 AS _INTEGER64, var2 AS SINGLE)
'Polar coordinate Y finder
'used to find Y coordinate of a speed/distance (var1) and heading/azimuth (var2)
CosCalc = var1 * COS(_D2R(var2))
END FUNCTION 'CosCalc
SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG)
DIM R AS INTEGER, RError AS INTEGER
DIM X AS INTEGER, Y AS INTEGER
R = ABS(RR)
RError = -R
X = R
Y = 0
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB
LINE (CX - X, CY)-(CX + X, CY), C, BF
WHILE X > Y
RError = RError + Y * 2 + 1
IF RError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
WEND
END SUB 'FCirc
Last edited:
