+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://qb64phoenix.com/forum/forumdisplay.php?fid=9)
+---- Thread: The Space Globe (/showthread.php?tid=3002)
The Space Globe - NakedApe - 09-03-2024
@Dav kindly thought I should put this in its own thread. A little 3D thing I was fooling around with over the long weekend. There's a single sound file below just for fun. I've been writing little bits for a new game I'm thinking about.
Code: (Select All)
Option _Explicit ' << SPACE GLOBE >>
Screen _NewImage(1280, 720, 32) ' by Ted Kluger
_MouseHide: _ScreenMove _Middle ' v.1.0
Type globe
x As Single '
y As Single
radius As Single
frameCol As _Unsigned Long
dotCol As _Unsigned Long
End Type
Dim As Long scanSnd
Dim globe(10) As globe
Dim As Integer i, j, k, bright, fCol(11), pSpot(11)
Dim As Single percent, radAdder, iOAspect(4), tempAsp(4), xScroller
Dim As _Byte grow, scan, signer, played
Dim Shared As Long starScape, starScape2
scanSnd = _SndOpen("fuzzyNoise.wav"): _SndVol scanSnd, .5
i = 1 ' it's all about the 1st globe right now
globe(i).radius = 5 ' start values
globe(i).x = _Width / 2
globe(i).y = _Height / 2
Data 1.15,1.4,1.8,2.7,5.8
For j = 0 To 4: Read iOAspect(j): Next ' store aspect data (inner Oval Aspects)
Data 60,90,110,130,160,181,190,182,160,137,100,70
For j = 0 To 11: Read fCol(j): Next ' store globe section fill greys
Data -122,-102,-82,-57,-35,-10,13,35,60,81,102,123
For j = 0 To 11: Read pSpot(j): Next ' store paint locations
grow = -1: scan = 0 ' flags
radAdder = .75: signer = 1 ' radius adder value & sign for scan
setStars ' create backdrop, software image
restart:
For j = 0 To 4: tempAsp(j) = iOAspect(j): Next ' initial aspects for inner ovals
Do ' --------------------------------------------------- * MAIN *
Cls
_Limit 120
xScroller = xScroller - .2 ' scroll stars to the left
_PutImage (0 + xScroller, 0), starScape
_PutImage (1281 + xScroller, 0), starScape2
If xScroller < -1280 Then xScroller = 0
radAdder = globe(i).radius * .0075 * Sgn(radAdder) ' rate of change is a factor of size
percent = globe(i).radius / 130 ' adjust paint points by radius / orig size
bright = globe(i).radius * 1.7 + 150 ' brightness = function of size
If bright > 254 Then bright = 255 ' mind the max
globe(i).frameCol = _RGB32(150) ' grey frame
globe(i).dotCol = _RGB32(255, 255, 0, bright) ' variable brightness for paint dot locs
Print "arrows to steer": Print "spacebar to stop/start"
Print "<s> to scan": Print "<esc> to exit" ' user inputs & controls
If _KeyDown(19200) Then globe(i).x = globe(i).x - 2.5 + globe(i).radius / 200 ' steers more when it's small, less when big
If _KeyDown(19712) Then globe(i).x = globe(i).x + 2.5 - globe(i).radius / 200
If _KeyDown(18432) Then globe(i).y = globe(i).y - 2 + globe(i).radius / 200
If _KeyDown(20480) Then globe(i).y = globe(i).y + 2 - globe(i).radius / 200
If _KeyHit = 32 Then ' space bar stops / starts movement
If grow <> 0 Then
grow = 0
_KeyClear
ElseIf grow = 0 Then grow = -1
_KeyClear
End If
End If
If grow Then ' size control
globe(i).radius = globe(i).radius + radAdder
If globe(i).radius > 250 Then radAdder = -radAdder
If globe(i).radius < 1 Then radAdder = -radAdder
End If
If _KeyDown(115) Or _KeyDown(83) Then scan = -1: _KeyClear ' scan = quick wiggle, show paint spots, move/color globe sections
If scan Then
j = 0
Do ' scan control
k = k + 1
If Not played And scanSnd > 0 Then _SndPlay scanSnd: played = -1
If k = 160 Or k = 320 Or k = 480 Then signer = -signer
globe(i).x = globe(i).x + .25 * signer
tempAsp(j) = tempAsp(j) + .08 ' was .05
j = j + 1
If tempAsp(j) > 5.5 Then tempAsp(j) = 1.15
Loop Until j = UBound(tempAsp)
If k > 600 Then
scan = 0: k = 0 ' scan resets itself
If _SndPlaying(scanSnd) Then _SndStop scanSnd: played = 0
GoTo restart
End If
End If ' ------------------------------
' draw globe
If scan And globe(i).radius > 10 Then ' if scan, paint inside of globe 1st
Circle (globe(i).x, globe(i).y), globe(i).radius - 3, _RGB32(255, 10, 0), , , 1
Paint (globe(i).x, globe(i).y), _RGB32(200, 100, 200, bright), _RGB32(255, 10, 0)
End If
Circle (globe(i).x, globe(i).y), globe(i).radius, globe(i).frameCol, , , 1 ' draw main circle
For j = 0 To 4
Circle (globe(i).x, globe(i).y), globe(i).radius, globe(i).frameCol, , , tempAsp(j) ' draw inside ovals
Next
Line (globe(i).x, globe(i).y - globe(i).radius)-(globe(i).x, globe(i).y + globe(i).radius), globe(i).frameCol ' middle line
If globe(i).radius > 8 Then ' was 10 paint globe sections
For j = 0 To 11
Paint (globe(i).x + (percent * pSpot(j)), globe(i).y), _RGB32(fCol(j), fCol(j), fCol(j), bright), globe(i).frameCol '
Next
If scan Then
For j = 0 To 11 ' draw paint spots during scan
If globe(i).radius < 30 Then ' was 80
PSet (globe(i).x + (percent * pSpot(j)), globe(i).y), globe(i).dotCol ' paint locs based on % of orig 130 radius @ x = 200
Else Circle (globe(i).x + (percent * pSpot(j)), globe(i).y), globe(i).radius / 102, globe(i).dotCol ' draw dots more to scale, sorta
End If
Next
End If
End If
_Display
Loop Until _KeyDown(27)
_SndClose scanSnd
System ' * END *
' ---------------------------------------------------------------
Sub setStars () ' starscape backdrop
Dim c As Integer
Dim As Long virtual
virtual = _NewImage(1280, 720, 32) '
_Dest virtual
c = 0
Do: c = c + 1
PSet ((Int(Rnd * _Width)), Int(Rnd * _Height)), _RGB32(190 + Rnd * 20) ' whites
Loop Until c = 2000
c = 0
Do: c = c + 1
PSet ((Int(Rnd * _Width)), Int(Rnd * _Height)), _RGB32(100 + Rnd * 22) ' grays
Loop Until c = 6000 '
starScape = _CopyImage(virtual, 32) ' software image
starScape2 = _CopyImage(virtual, 32) ' another copy to allow sideways scrolling
_Dest 0: _FreeImage virtual
End Sub
RE: The Space Globe - bplus - 09-04-2024
@NakedApe
Check this out:
https://qb64phoenix.com/forum/showthread.php?tid=272&pid=2647#pid2647
titled: Image to Sphere and Rotate under Drawing Tools
RE: The Space Globe - Dav - 09-04-2024
(09-04-2024, 08:50 PM)bplus Wrote: @NakedApe
Check this out:
https://qb64phoenix.com/forum/showthread.php?tid=272&pid=2647#pid2647
titled: Image to Sphere and Rotate under Drawing Tools
Oh wow! How did I miss seeing that image to sphere thing? Must have been while I was away for a while. That's really cool.
- Dav
RE: The Space Globe - NakedApe - 09-04-2024
Wow, that's awesome, @bplus! I wish I had your skills. I could easily see making use of that baby - with proper attribution of course.
Thanks for the redirect.
RE: The Space Globe - bplus - 09-04-2024
(09-04-2024, 09:34 PM)NakedApe Wrote: Wow, that's awesome, @bplus! I wish I had your skills. I could easily see making use of that baby - with proper attribution of course.
Well proper attribution would have to start with some cool code ZXDunny did in SpecBas years ago and posted at a forum now gone. Stole and studied and generalized into a subroutine in QB64 over the years by yours truely.
