Posts: 499
Threads: 89
Joined: Apr 2022
Reputation:
32
Happy New Year Everyone!
Code: (Select All)
_Title "H A P P Y N E W Y E A R ! ! ! ! From SierraKen"
' Constants
Const pi = _Pi
Const radius = 275
centerX = 400
centerY = 300
' Rotation angles
Dim angleX As Single, angleY As Single
angleX = 90
angleY = 0
xx = 400: yy = 50
'Dim x As Single, y As Single
dir1 = 1
dir2 = 1
a& = _NewImage(800, 600, 32)
Screen a&
Color 1
Locate 1, 32: Print "Happy New Year!!!!"
For I = 248 To 375 Step .15
For j = 0 To 12 Step .15
If Point(I, j) > 0 Then
Line ((I - 211) * 4, j * 4 + 50)-((I - 211) * 4 + 2, j * 4 + 52), _RGB32(0, 0, 0), BF
Else
PSet ((I - 211) * 4, j * 4 + 50), _RGB32(0, 255, 0)
End If
Next j
Next I
a& = _CopyImage(0)
b& = _NewImage(800, 600, 32)
Screen b&
_Dest b&
r = 100: g = 10: b = 10
dirc = 1
Do
Cls
_PutImage (xx, yy), a&, b&
If dirc = 1 Then
r = r + 5
g = 10
b = 10
End If
If r > 255 Then dirc = 2
If dirc = 2 Then r = r - 5
If dirc = 2 And r < 50 Then dirc = 3
If dirc = 3 Then
r = 10
b = 10
g = g + 5
End If
If g > 255 Then dirc = 4
If dirc = 4 Then g = g - 5
If dirc = 4 And g < 50 Then dirc = 5
If dirc = 5 Then
r = 10
g = 10
b = b + 5
End If
If b > 255 Then dirc = 6
If dirc = 6 Then b = b - 5
If dirc = 6 And b < 50 Then dirc = 1
If dir1 = 1 Then xx = xx + 10
If xx > 150 Then dir1 = 2
If dir1 = 2 Then xx = xx - 10
If xx < -150 Then dir1 = 1
If dir2 = 1 Then yy = yy + 10
If yy > 500 Then dir2 = 2
If dir2 = 2 Then yy = yy - 10
If yy < -50 Then dir2 = 1
' Draw latitude lines
For lat = -pi / 2 To pi / 2 Step pi / 18
Dim prevX As Single, prevY As Single
For lon = 0 To 5 * pi Step pi / 36
Call SphericalTo2D(lat, lon, x, y, angleX, angleY, centerX, centerY)
If lon > 0 Then Line (prevX, prevY)-(x, y), _RGB32(r, g, b)
prevX = x
prevY = y
Next lon
Next lat
' Draw longitude lines
For lon = 0 To 5 * pi Step pi / 12
For lat = -pi / 2 To pi / 2 Step pi / 36
Call SphericalTo2D(lat, lon, x, y, angleX, angleY, centerX, centerY)
If lat > -pi / 2 Then Line (prevX, prevY)-(x, y), _RGB32(r, g, b)
prevX = x
prevY = y
Next lat
Next lon
' Update rotation angles
angleX = angleX + 0.02
angleY = angleY + 0.5
_Delay .1
_Display
Loop Until InKey$ <> ""
End
' Subroutine to convert spherical coordinates to 2D projection
Sub SphericalTo2D (lat As Single, lon As Single, x As Single, y As Single, angleX As Single, angleY As Single, centerx As Single, centery As Single)
' Convert latitude and longitude to 3D coordinates
Dim x3D As Single, y3D As Single, z3D As Single
x3D = radius * Cos(lat) * Cos(lon)
y3D = radius * Cos(lat) * Sin(lon)
z3D = radius * Sin(lat)
' Apply rotation around the X-axis
Dim tempY As Single, tempZ As Single
tempY = y3D * Cos(angleX) - z3D * Sin(angleX)
tempZ = y3D * Sin(angleX) + z3D * Cos(angleX)
y3D = tempY
z3D = tempZ
' Apply rotation around the Y-axis
Dim tempX As Single
tempX = x3D * Cos(angleY) + z3D * Sin(angleY)
z3D = -x3D * Sin(angleY) + z3D * Cos(angleY)
x3D = tempX
' Project the 3D point onto 2D screen
x = centerx + x3D
y = centery - y3D
End Sub
Posts: 4,054
Threads: 181
Joined: Apr 2022
Reputation:
231
+1 @SierraKen I luv this timely application of Globe Drawing!
I did rework getting the message created in an image, so it could be overlayed on the globe image so that the lines from the globe don't show on your new years message.
That's when I found that the copy(0) was poor way to get projected print line into an image.
I created separate mess container to project the printed line on main screen into an image with handle mess.
I tried to comment everything I did to make clear. what I fixed up. More effort than I expected just to get some lines out of the way! 
Code: (Select All) Option _Explicit
' major mod by bplus to correct messy imaging of text projection
' I changed a number of other things to attempt to clarify what is going on.
' That globe drawing code is basically excellent!
' New Years message is perfect application of globe drawing!
' I luv it!
_Title "H A P P Y N E W Y E A R ! ! ! ! From SierraKen"
Screen _NewImage(800, 600, 32)
' Variables for creating the message into a separate image handle name mess
Dim mess As Long, message$, xOffset, yOffset, x, y
mess = _NewImage(800, 600, 32)
message$ = "Happy New Year!"
Locate 1, 1: Print message$
mess = _NewImage(800, 600, 32) ' set up place to project Points of Text into
' start drawing on side screen called mess the handle
_Dest mess
' to center message on 800 x 600 need x and y offsets for projecting points from
' message printed on main screen
' a letter cell is 8 X 16 pixels 8 for X across and 16 for y down
' now in our projection of the points on main screen to mess, we are scale up by 4
' that means mulyiply x's across by 4 and y's down by 4
xOffset = (800 - Len(message$) * 8 * 4) / 2 ' pixels to right to center the message
yOffset = (600 - 16 * 4) / 2
_Source 0 ' now reading points on main screen project them bigger X's 4 onto center of mess
For y = 0 To 15 ' down 16 pixels
For x = 0 To Len(message$) * 8 - 1 ' across 8 * letters in message -1 because start at 0
If Point(x, y) <> Point(0, 0) Then
Line (x * 4 + xOffset, y * 4 + yOffset)-Step(4, 4), _RGB32(0, 255, 0), BF
End If
Next
Next
_Dest 0 ' stop drawing to mess and go back to drawing on main screen
'' check our mess screen
'Cls , &HFF330066 ' clear main screen with purple color
'_PutImage , mess, 0 ' overlays mess over main screen
'Sleep ' <<< check this image OK (finally)
' Variables for globe
Dim As Long globe, R, G, B, dirc
Dim Shared pi, radius, centerX, centerY
Dim angleX, angleY, xx, yy, dir1, dir2, lat, lon
pi = _Pi
radius = 275
centerX = 400: centerY = 300
angleX = 90: angleY = 0
xx = 400 - xOffset: yy = 300 - yOffset
dir1 = 1: dir2 = 1
globe = _NewImage(800, 600, 32)
R = 100: G = 10: B = 10
dirc = 1
Do
Cls
' these change the colors of globe and spin AND rotate it
If dirc = 1 Then
R = R + 5
G = 10
B = 10
End If
If R > 255 Then dirc = 2
If dirc = 2 Then R = R - 5
If dirc = 2 And R < 50 Then dirc = 3
If dirc = 3 Then
R = 10
B = 10
G = G + 5
End If
If G > 255 Then dirc = 4
If dirc = 4 Then G = G - 5
If dirc = 4 And G < 50 Then dirc = 5
If dirc = 5 Then
R = 10
G = 10
B = B + 5
End If
If B > 255 Then dirc = 6
If dirc = 6 Then B = B - 5
If dirc = 6 And B < 50 Then dirc = 1
' this bounces message off edges of screen
If dir1 = 1 Then xx = xx + 10
If xx > 799 - Len(message$) * 8 * 4 Then dir1 = 2
If dir1 = 2 Then xx = xx - 10
If xx <= 0 Then dir1 = 1
If dir2 = 1 Then yy = yy + 10
If yy > 600 - 16 * 4 Then dir2 = 2
If dir2 = 2 Then yy = yy - 10
If yy <= 0 Then dir2 = 1
_Dest globe ' the followings really nice code!
Cls
' Draw latitude lines
For lat = -pi / 2 To pi / 2 Step pi / 18
Dim prevX As Single, prevY As Single
For lon = 0 To 5 * pi Step pi / 36
Call SphericalTo2D(lat, lon, x, y, angleX, angleY, centerX, centerY)
If lon > 0 Then Line (prevX, prevY)-(x, y), _RGB32(R, G, B)
prevX = x
prevY = y
Next lon
Next lat
' Draw longitude lines
For lon = 0 To 5 * pi Step pi / 12
For lat = -pi / 2 To pi / 2 Step pi / 36
Call SphericalTo2D(lat, lon, x, y, angleX, angleY, centerX, centerY)
If lat > -pi / 2 Then Line (prevX, prevY)-(x, y), _RGB32(R, G, B)
prevX = x
prevY = y
Next lat
Next lon
_Dest 0
' Update rotation angles
angleX = angleX + 0.02
angleY = angleY + 0.5
_PutImage , globe, 0
_PutImage (xx - xOffset, yy - yOffset), mess, 0 ' <<< do this AFTER draw globe so globe lines don't overlap print
'_Delay .1 ' <<< _Limit here might work more smoothly
' the higher the limit number the more frames per second your main loop goes
_Limit 5 ' <<< 60 is a good start number to test = 60 loops of code displayed slowed way down to 5!
_Display
Loop Until InKey$ <> ""
' Subroutine to convert spherical coordinates to 2D projection
' This is excellent routine!!!
Sub SphericalTo2D (lat As Single, lon As Single, outX As Single, outY As Single, angleX As Single, angleY As Single, centerx As Single, centery As Single)
' Convert latitude and longitude to 3D coordinates
Dim x3D As Single, y3D As Single, z3D As Single
x3D = radius * Cos(lat) * Cos(lon)
y3D = radius * Cos(lat) * Sin(lon)
z3D = radius * Sin(lat)
' Apply rotation around the X-axis
Dim tempY As Single, tempZ As Single
tempY = y3D * Cos(angleX) - z3D * Sin(angleX)
tempZ = y3D * Sin(angleX) + z3D * Cos(angleX)
y3D = tempY
z3D = tempZ
' Apply rotation around the Y-axis
Dim tempX As Single
tempX = x3D * Cos(angleY) + z3D * Sin(angleY)
z3D = -x3D * Sin(angleY) + z3D * Cos(angleY)
x3D = tempX
' Project the 3D point onto 2D screen
outX = centerx + x3D
outY = centery - y3D
End Sub
b = b + ...
Posts: 499
Threads: 89
Joined: Apr 2022
Reputation:
32
Awesome, thanks B+! I have to learn by practice so I will try to use this as a template. Feel free to snag the routine or anything else for anything you make, I got it from ChatGPT. lol I wish I was that smart! 
|
