' Rotate around X axis
y1 = y * Cos(_D2R(rotationX)) - z * Sin(_D2R(rotationX))
z1 = y * Sin(_D2R(rotationX)) + z * Cos(_D2R(rotationX))
y = y1
z = z1
' Rotate around Y axis
x1 = x * Cos(_D2R(rotationY)) + z * Sin(_D2R(rotationY))
z1 = -x * Sin(_D2R(rotationY)) + z * Cos(_D2R(rotationY))
x = x1
z = z1
' Project to 2D
screenX = 400 + x * 200
screenY = 300 - y * 200 PSet (screenX, screenY), sphere(phi, theta) Next Next
Hi. This program was created in collaboration. I was interested in it. By modifying the scale, you can zoom in and out on the textured sphere. The whole thing is created using 2D commands, instead of PSet I used _MapTriangle (in the 2D version) because you write here that you want to rotate the sphere and you don't write anything about approaching it with jumps. There was a problem with the fact that the back and front parts were redrawn, so you had to determine which part was visible and only that was drawn. I left Czech and English comments in the program, because I'm sure I'll come back to it.
Code: (Select All)
' Rotující texturovaná koule vykreslená pomocí _MAPTRIANGLE s backface culling
' (Rotating textured sphere rendered using _MAPTRIANGLE with backface culling)
Screen _NewImage(800, 600, 32)
myTexture = _LoadImage("6.jpg")
If myTexture = 0 Then
Print "Can not load '6.jpg'!"
End
End If
texWidth = _Width(myTexture)
texHeight = _Height(myTexture)
' (Obtaining the width and height of the loaded texture)
Const PI = 3.14159265
Const centerX = 400 ' Střed obrazovky (X) Screen middle X
Const centerY = 300 ' Střed obrazovky (Y) Screen middle Y
Const scale = 200 ' Měřítko projekce Projection ratio
' (Define constants for PI, screen center coordinates, and the projection scale)
' Nastavení rozlišení sítě (kolik segmentů se použije)
' (Setting the mesh resolution - how many segments to use)
Const nPhi = 40 ' Počet dělení kolem osy (azimut) Number of divisions around the axis (azimuth)
Const nTheta = 20 ' Počet dělení od pólu k pólu (polární úhel) Number of divisions from pole to pole (polar angle)
Dim stepPhi As Single, stepTheta As Single
stepPhi = 360 / nPhi
stepTheta = 180 / nTheta
' (Calculates the angular step sizes for phi (azimuth) and theta (polar angle))
' (User Defined Type with additional fields for 3D coordinates used for backface culling)
Type Vertex
sx As Integer ' Projekční X na obrazovce Projection X on screen
sy As Integer ' Projekční Y na obrazovce Projection Y on screen
u As Single ' Texturovací souřadnice U (0 až 1) Texturing coordinate U 0 to 1
v As Single ' Texturovací souřadnice V (0 až 1) Texturing coordinate V 0 to 1
x3d As Single ' Otočená 3D souřadnice X rotation 3D X
y3d As Single ' Otočená 3D souřadnice Y rotation 3D Y
z3d As Single ' Otočená 3D souřadnice Z rotation 3D Z
End Type
' (The Vertex type stores both the 2D projected coordinates (sx, sy) and the texture coordinates (u, v),
' as well as the transformed 3D coordinates (x3d, y3d, z3d) for performing backface culling)
' Globální rotační úhly (v°)
' (Global rotation angles in degrees)
Dim rotationX As Single, rotationY As Single
rotationX = 0
rotationY = 0
Do
' Používáme původní _KeyDown hodnoty
' (Using the original _KeyDown key codes)
If _KeyDown(18432) Then rotationX = rotationX - 5 ' Šipka vlevo (Left arrow decreases rotationX)
If _KeyDown(20480) Then rotationX = rotationX + 5 ' Šipka vpravo (Right arrow increases rotationX)
If _KeyDown(19200) Then rotationY = rotationY - 5 ' Šipka nahoru (Up arrow decreases rotationY)
If _KeyDown(19712) Then rotationY = rotationY + 5 ' Šipka dolů (Down arrow increases rotationY)
Cls , 0
_PrintString (0, 0), "Rotující texturovaná koule s backface culling"
_PrintString (0, 16), "Použijte šipky. ESC pro ukončení."
_PrintString (0, 32), "rotationX = " + Str$(rotationX) + " rotationY = " + Str$(rotationY)
' (Clears the screen and prints the title and current rotation angles for debugging)
Dim i As Integer, j As Integer
Dim phi1 As Single, phi2 As Single, theta1 As Single, theta2 As Single
Dim v1 As Vertex, v2 As Vertex, v3 As Vertex, v4 As Vertex
' Procházení sférickou sítí – každý segment (čtverec) rozdělíme na 2 trojúhelníky
' (Loop through the spherical mesh; each quad (square) is divided into 2 triangles)
For i = 0 To nPhi - 1
For j = 0 To nTheta - 1
phi1 = i * stepPhi
phi2 = (i + 1) * stepPhi
If phi2 >= 360 Then phi2 = phi2 - 360
theta1 = j * stepTheta
theta2 = (j + 1) * stepTheta
' Výpočet vrcholů segmentu – předáváme aktuální hodnoty rotace
' (Calculate the vertices of the segment, passing the current rotation values)
GetVertex v1, phi1, theta1, rotationX, rotationY
GetVertex v2, phi2, theta1, rotationX, rotationY
GetVertex v3, phi1, theta2, rotationX, rotationY
GetVertex v4, phi2, theta2, rotationX, rotationY
' Vykreslíme pouze trojúhelníky, které jsou "front-facing"
' (Render only the triangles that are front-facing)
If IsFrontFace(v1, v2, v3) Then
_MapTriangle (v1.u * texWidth, v1.v * texHeight)-(v2.u * texWidth, v2.v * texHeight)-(v3.u * texWidth, v3.v * texHeight), myTexture To(v1.sx, v1.sy)-(v2.sx, v2.sy)-(v3.sx, v3.sy), _Smooth
End If
If IsFrontFace(v2, v4, v3) Then
_MapTriangle (v2.u * texWidth, v2.v * texHeight)-(v4.u * texWidth, v4.v * texHeight)-(v3.u * texWidth, v3.v * texHeight), myTexture To(v2.sx, v2.sy)-(v4.sx, v4.sy)-(v3.sx, v3.sy), _Smooth
End If
Next j
Next i
_Display
Loop Until _KeyDown(27) ' ESC ukončí program
' (The main loop continues until the ESC key is pressed)
'------------------------------------------------------
' SUB GetVertex
'
' Vstup:
' phi, theta: sférické úhly (v°)
' rotX, rotY: aktuální hodnoty rotace (v°), předané z hlavního programu
'
' Výstup (v):
' v.sx, v.sy: 2D projekční souřadnice
' v.u, v.v: texturovací souřadnice (v rozsahu 0 až 1)
' v.x3d, v.y3d, v.z3d: otočené 3D souřadnice (pro backface culling)
'
' Postup:
' 1. Vypočítá se původní (neotočený) bod na jednotkové kouli:
' x0 = sin(theta)*cos(phi)
' y0 = cos(theta)
' z0 = sin(theta)*sin(phi)
' 2. Z tohoto bodu se spočítají texturovací souřadnice:
' u = (ATAN2(z0, x0) + PI) / (2*PI)
' v = ACOS(y0) / PI
' 3. Následně se na původní bod aplikuje rotace – nejprve kolem osy Y, potom kolem osy X.
' 4. Výsledek se uloží do v.x3d, v.y3d, v.z3d a podle něj se spočítají 2D projekční souřadnice.
'
' Input:
' phi, theta: spherical angles (v°)
' rotX, rotY: current rotation values ??(v°), passed from the main program
'
' Output (v):
' v.sx, v.sy: 2D projection coordinates
' v.u, v.v: texturing coordinates (in the range 0 to 1)
' v.x3d, v.y3d, v.z3d: rotated 3D coordinates (for backface culling)
'
' Procedure:
' 1. The original (unrotated) point on the unit sphere is calculated:
' x0 = sin(theta)*cos(phi)
' y0 = cos(theta)
' z0 = sin(theta)*sin(phi)
' 2. The texturing coordinates are calculated from this point:
' u = (ATAN2(z0, x0) + PI) / (2*PI)
' v = ACOS(y0) / PI
' 3. Subsequently, on the original point is rotated – first around the Y axis, then around the X axis.
' 4. The result is stored in v.x3d, v.y3d, v.z3d and the 2D projection coordinates are calculated based on it.
' (SUB GetVertex calculates the vertex data for a given spherical coordinate.
' It computes the original (unrotated) point on the unit sphere, derives the texture coordinates,
' then applies rotation (first around the Y-axis, then around the X-axis) and computes the 2D projection.)
'------------------------------------------------------
Sub GetVertex (v As Vertex, phi As Single, theta As Single, rotX As Single, rotY As Single)
Dim radPhi As Single, radTheta As Single
radPhi = phi * (PI / 180)
radTheta = theta * (PI / 180)
' Původní (neotočený) bod na jednotkové kouli
' (Calculate the original, unrotated point on the unit sphere)
Dim x0 As Single, y0 As Single, z0 As Single
x0 = Sin(radTheta) * Cos(radPhi)
y0 = Cos(radTheta)
z0 = Sin(radTheta) * Sin(radPhi)
' Výpočet texturovacích souřadnic (z neotočeného bodu)
' (Calculate texture coordinates from the unrotated point)
v.u = (_Atan2(z0, x0) + PI) / (2 * PI)
v.v = _Acos(y0) / PI
' Inicializace – budeme transformovat původní bod
' (Initialize transformation with the original point)
Dim x As Single, y As Single, z As Single
x = x0: y = y0: z = z0
' Nejprve rotace kolem osy Y (vertikální rotace)
' (Apply rotation around the Y-axis first - vertical rotation)
Dim ry As Single
ry = rotY * (PI / 180)
Dim xtemp As Single, ztemp As Single
xtemp = x * Cos(ry) + z * Sin(ry)
ztemp = -x * Sin(ry) + z * Cos(ry)
x = xtemp: z = ztemp
' Poté rotace kolem osy X (horizontální rotace)
' (Then apply rotation around the X-axis - horizontal rotation)
Dim rx As Single
rx = rotX * (PI / 180)
Dim ytemp As Single
ytemp = y * Cos(rx) - z * Sin(rx)
ztemp = y * Sin(rx) + z * Cos(rx)
y = ytemp: z = ztemp
' Uložení otočených 3D souřadnic do vrcholu (pro pozdější backface culling)
' (Store the rotated 3D coordinates in the vertex for later backface culling)
v.x3d = x
v.y3d = y
v.z3d = z
' Projekce do 2D (ortografická)
' (Calculate the 2D orthographic projection)
v.sx = centerX + x * scale
v.sy = centerY - y * scale
End Sub
'------------------------------------------------------
' Funkce IsFrontFace
'
' Vstup: tři vrcholy trojúhelníku (v1, v2, v3) se svými 3D souřadnicemi.
' Výpočet: spočítá se normála trojúhelníku a poté její dot produkt s vektorem pohledu (0,0,-1).
' Pokud je výsledek > 0 (tj. normála směřuje ke kameře), vrátí funkce true.
' V našem případě (s ortografickou projekcí a kamerou směřující do -Z)
' platí: pokud normála má složku z menší než 0, trojúhelník je viditelný.
'
' (Function IsFrontFace determines whether a triangle is facing the camera.
' It calculates the cross product (normal) of two edges of the triangle and uses its Z-component,
' comparing it with the view vector (0,0,-1). If the condition is met (normal's Z-component < 0),
' the triangle is considered front-facing.)
'------------------------------------------------------
Function IsFrontFace (v1 As Vertex, v2 As Vertex, v3 As Vertex)
Dim edge1_x As Single, edge1_y As Single, edge1_z As Single
Dim edge2_x As Single, edge2_y As Single, edge2_z As Single
edge1_x = v2.x3d - v1.x3d
edge1_y = v2.y3d - v1.y3d
edge1_z = v2.z3d - v1.z3d
edge2_x = v3.x3d - v1.x3d
edge2_y = v3.y3d - v1.y3d
edge2_z = v3.z3d - v1.z3d
' Vypočítáme pouze složku Z normály (cross product)
' (Compute only the Z component of the normal via cross product)
Dim norm_z As Single
norm_z = edge1_x * edge2_y - edge1_y * edge2_x
' Pohled: vektor (0,0,-1). Dot produkt = -norm_z.
' Trojúhelník je front-facing, pokud -norm_z > 0 <=> norm_z < 0.
' (With the view vector (0,0,-1), the dot product is -norm_z.
' The triangle is considered front-facing if -norm_z > 0, i.e., if norm_z < 0.)
If norm_z < 0 Then
IsFrontFace = -1
Else
IsFrontFace = 0
End If
End Function
02-09-2025, 06:34 PM (This post was last modified: 02-09-2025, 06:36 PM by SMcNeill.)
@Petr This is pretty great! One glitch though -- it doesn't map the whole earth, leaving a crack where some celestial giant took an axe to one side of it...
Code: (Select All)
' Rotující texturovaná koule vykreslená pomocí _MAPTRIANGLE s backface culling ' (Rotating textured sphere rendered using _MAPTRIANGLE with backface culling)
texWidth = _Width(myTexture)
texHeight = _Height(myTexture) ' (Obtaining the width and height of the loaded texture)
Const PI = 3.14159265 Const centerX = 400' Stred obrazovky (X) Screen middle X Const centerY = 300' Stred obrazovky (Y) Screen middle Y Const scale = 200' Merítko projekce Projection ratio ' (Define constants for PI, screen center coordinates, and the projection scale)
' Nastavení rozlišení síte (kolik segmentu se použije) ' (Setting the mesh resolution - how many segments to use) Const nPhi = 40' Pocet delení kolem osy (azimut) Number of divisions around the axis (azimuth) Const nTheta = 20' Pocet delení od pólu k pólu (polární úhel) Number of divisions from pole to pole (polar angle) Dim stepPhi AsSingle, stepTheta AsSingle
stepPhi = 360 / nPhi
stepTheta = 180 / nTheta ' (Calculates the angular step sizes for phi (azimuth) and theta (polar angle))
' (User Defined Type with additional fields for 3D coordinates used for backface culling) Type Vertex
sx AsInteger' Projekcní X na obrazovce Projection X on screen
sy AsInteger' Projekcní Y na obrazovce Projection Y on screen
u AsSingle' Texturovací souradnice U (0 až 1) Texturing coordinate U 0 to 1
v AsSingle' Texturovací souradnice V (0 až 1) Texturing coordinate V 0 to 1
x3d AsSingle' Otocená 3D souradnice X rotation 3D X
y3d AsSingle' Otocená 3D souradnice Y rotation 3D Y
z3d AsSingle' Otocená 3D souradnice Z rotation 3D Z End Type ' (The Vertex type stores both the 2D projected coordinates (sx, sy) and the texture coordinates (u, v), ' as well as the transformed 3D coordinates (x3d, y3d, z3d) for performing backface culling)
Do ' Používáme puvodní _KeyDown hodnoty ' (Using the original _KeyDown key codes) If_KeyDown(18432) Then rotationX = rotationX - 1' Šipka vlevo (Left arrow decreases rotationX) If_KeyDown(20480) Then rotationX = rotationX + 1' Šipka vpravo (Right arrow increases rotationX) If_KeyDown(19200) Then rotationY = rotationY - 1' Šipka nahoru (Up arrow decreases rotationY) If_KeyDown(19712) Then rotationY = rotationY + 1' Šipka dolu (Down arrow increases rotationY)
Cls , 0 _PrintString (0, 0), "Rotující texturovaná koule s backface culling" _PrintString (0, 16), "Použijte šipky. ESC pro ukoncení." _PrintString (0, 32), "rotationX = " + Str$(rotationX) + " rotationY = " + Str$(rotationY) ' (Clears the screen and prints the title and current rotation angles for debugging)
' Procházení sférickou sítí – každý segment (ctverec) rozdelíme na 2 trojúhelníky ' (Loop through the spherical mesh; each quad (square) is divided into 2 triangles) For i = 0To nPhi - 1 For j = 0To nTheta - 1
phi1 = i * stepPhi
phi2 = (i + 1) * stepPhi If phi2 >= 360Then phi2 = phi2 - 360
theta1 = j * stepTheta
theta2 = (j + 1) * stepTheta
' Výpocet vrcholu segmentu – predáváme aktuální hodnoty rotace ' (Calculate the vertices of the segment, passing the current rotation values) GetVertex v1, phi1, theta1, rotationX, rotationY GetVertex v2, phi2, theta1, rotationX, rotationY GetVertex v3, phi1, theta2, rotationX, rotationY GetVertex v4, phi2, theta2, rotationX, rotationY
' Vykreslíme pouze trojúhelníky, které jsou "front-facing" ' (Render only the triangles that are front-facing) IfIsFrontFace(v1, v2, v3) Then _MapTriangle (v1.u * texWidth, v1.v * texHeight)-(v2.u * texWidth, v2.v * texHeight)-(v3.u * texWidth, v3.v * texHeight), myTexture To(v1.sx, v1.sy)-(v2.sx, v2.sy)-(v3.sx, v3.sy), _Smooth End If IfIsFrontFace(v2, v4, v3) Then _MapTriangle (v2.u * texWidth, v2.v * texHeight)-(v4.u * texWidth, v4.v * texHeight)-(v3.u * texWidth, v3.v * texHeight), myTexture To(v2.sx, v2.sy)-(v4.sx, v4.sy)-(v3.sx, v3.sy), _Smooth End If Next j Next i _Limit30 _Display Loop Until_KeyDown(27) ' ESC ukoncí program ' (The main loop continues until the ESC key is pressed)
'------------------------------------------------------ ' SUB GetVertex ' ' Vstup: ' phi, theta: sférické úhly (v° ' rotX, rotY: aktuální hodnoty rotace (v°, predané z hlavního programu ' ' Výstup (v): ' v.sx, v.sy: 2D projekcní souradnice ' v.u, v.v: texturovací souradnice (v rozsahu 0 až 1) ' v.x3d, v.y3d, v.z3d: otocené 3D souradnice (pro backface culling) ' ' Postup: ' 1. Vypocítá se puvodní (neotocený bod na jednotkové kouli: ' x0 = sin(theta)*cos(phi) ' y0 = cos(theta) ' z0 = sin(theta)*sin(phi) ' 2. Z tohoto bodu se spocítají texturovací souradnice: ' u = (ATAN2(z0, x0) + PI) / (2*PI) ' v = ACOS(y0) / PI ' 3. Následne se na puvodní bod aplikuje rotace – nejprve kolem osy Y, potom kolem osy X. ' 4. Výsledek se uloží do v.x3d, v.y3d, v.z3d a podle nej se spocítají 2D projekcní souradnice. ' ' Input: ' phi, theta: spherical angles (v° ' rotX, rotY: current rotation values ??(v°, passed from the main program ' ' Output (v): ' v.sx, v.sy: 2D projection coordinates ' v.u, v.v: texturing coordinates (in the range 0 to 1) ' v.x3d, v.y3d, v.z3d: rotated 3D coordinates (for backface culling) ' ' Procedure: ' 1. The original (unrotated) point on the unit sphere is calculated: ' x0 = sin(theta)*cos(phi) ' y0 = cos(theta) ' z0 = sin(theta)*sin(phi) ' 2. The texturing coordinates are calculated from this point: ' u = (ATAN2(z0, x0) + PI) / (2*PI) ' v = ACOS(y0) / PI ' 3. Subsequently, on the original point is rotated – first around the Y axis, then around the X axis. ' 4. The result is stored in v.x3d, v.y3d, v.z3d and the 2D projection coordinates are calculated based on it.
' (SUB GetVertex calculates the vertex data for a given spherical coordinate. ' It computes the original (unrotated) point on the unit sphere, derives the texture coordinates, ' then applies rotation (first around the Y-axis, then around the X-axis) and computes the 2D projection.) '------------------------------------------------------ SubGetVertex (v As Vertex, phi AsSingle, theta AsSingle, rotX AsSingle, rotY AsSingle) Dim radPhi AsSingle, radTheta AsSingle
radPhi = phi * (PI / 180)
radTheta = theta * (PI / 180)
' Puvodní (neotocený bod na jednotkové kouli ' (Calculate the original, unrotated point on the unit sphere) Dim x0 AsSingle, y0 AsSingle, z0 AsSingle
x0 = Sin(radTheta) * Cos(radPhi)
y0 = Cos(radTheta)
z0 = Sin(radTheta) * Sin(radPhi)
' Výpocet texturovacích souradnic (z neotoceného bodu) ' (Calculate texture coordinates from the unrotated point)
v.u = (_Atan2(z0, x0) + PI) / (2 * PI)
v.v = _Acos(y0) / PI
' Inicializace – budeme transformovat puvodní bod ' (Initialize transformation with the original point) Dim x AsSingle, y AsSingle, z AsSingle
x = x0: y = y0: z = z0
' Nejprve rotace kolem osy Y (vertikální rotace) ' (Apply rotation around the Y-axis first - vertical rotation) Dim ry AsSingle
ry = rotY * (PI / 180) Dim xtemp AsSingle, ztemp AsSingle
xtemp = x * Cos(ry) + z * Sin(ry)
ztemp = -x * Sin(ry) + z * Cos(ry)
x = xtemp: z = ztemp
' Poté rotace kolem osy X (horizontální rotace) ' (Then apply rotation around the X-axis - horizontal rotation) Dim rx AsSingle
rx = rotX * (PI / 180) Dim ytemp AsSingle
ytemp = y * Cos(rx) - z * Sin(rx)
ztemp = y * Sin(rx) + z * Cos(rx)
y = ytemp: z = ztemp
' Uložení otocených 3D souradnic do vrcholu (pro pozdejší backface culling) ' (Store the rotated 3D coordinates in the vertex for later backface culling)
v.x3d = x
v.y3d = y
v.z3d = z
' Projekce do 2D (ortografická ' (Calculate the 2D orthographic projection)
v.sx = centerX + x * scale
v.sy = centerY - y * scale End Sub
'------------------------------------------------------ ' Funkce IsFrontFace ' ' Vstup: tri vrcholy trojúhelníku (v1, v2, v3) se svými 3D souradnicemi. ' Výpocet: spocítá se normála trojúhelníku a poté její dot produkt s vektorem pohledu (0,0,-1). ' Pokud je výsledek > 0 (tj. normála smeruje ke kamere), vrátí funkce true. ' V našem prípade (s ortografickou projekcí a kamerou smerující do -Z) ' platí: pokud normála má složku z menší než 0, trojúhelník je viditelný. ' ' (Function IsFrontFace determines whether a triangle is facing the camera. ' It calculates the cross product (normal) of two edges of the triangle and uses its Z-component, ' comparing it with the view vector (0,0,-1). If the condition is met (normal's Z-component < 0), ' the triangle is considered front-facing.) '------------------------------------------------------ FunctionIsFrontFace (v1 As Vertex, v2 As Vertex, v3 As Vertex) Dim edge1_x AsSingle, edge1_y AsSingle, edge1_z AsSingle Dim edge2_x AsSingle, edge2_y AsSingle, edge2_z AsSingle
edge1_x = v2.x3d - v1.x3d
edge1_y = v2.y3d - v1.y3d
edge1_z = v2.z3d - v1.z3d
edge2_x = v3.x3d - v1.x3d
edge2_y = v3.y3d - v1.y3d
edge2_z = v3.z3d - v1.z3d ' Vypocítáme pouze složku Z normály (cross product) ' (Compute only the Z component of the normal via cross product) Dim norm_z AsSingle
norm_z = edge1_x * edge2_y - edge1_y * edge2_x ' Pohled: vektor (0,0,-1). Dot produkt = -norm_z. ' Trojúhelník je front-facing, pokud -norm_z > 0 <=> norm_z < 0. ' (With the view vector (0,0,-1), the dot product is -norm_z. ' The triangle is considered front-facing if -norm_z > 0, i.e., if norm_z < 0.) If norm_z < 0Then IsFrontFace = -1 Else IsFrontFace = 0 End If End Function
The image of the earth is included as an attachment so you can test it yourself. (Just change the path to wherever you put the earth.bmp file.)
If only that seam.... There was an artifact running across the planet. Sometimes. It's not there anymore. Then there was a bug in the IsFrontFace function that did really nasty things to the north and south poles after the artifact was fixed. So that's gone too. So it should be fine now.
Code: (Select All)
' Rotating textured sphere with backface culling and precise continuity between the poles and the middle band
' We use specially calculated edge vertices for the poles to ensure that the vertices used in the middle band and in the pole fans exactly match.
Screen _NewImage(800, 600, 32)
myTexture = _LoadImage("earth.bmp")
If myTexture = 0 Then
Print "Cannot load texture!"
End
End If
texWidth = _Width(myTexture)
texHeight = _Height(myTexture)
' Obtaining texture dimensions
Const PI = 3.14159265
Const centerX = 400 ' Screen center (X)
Const centerY = 300 ' Screen center (Y)
Const scale = 250 ' Projection scale
' Setting the resolution of the spherical mesh
Const nPhi = 20 ' Number of divisions around the axis (azimuth)
Const nTheta = 20 ' Number of divisions from pole to pole (polar angle)
Dim stepPhi As Single, stepTheta As Single
stepPhi = 360 / nPhi
stepTheta = 180 / nTheta
' Definition of type Vertex – contains 2D projection, texture coordinates and rotated 3D coordinates
Type Vertex
sx As Integer ' 2D projected X
sy As Integer ' 2D projected Y
u As Single ' Texture coordinate U (0 to 1)
v As Single ' Texture coordinate V (0 to 1)
x3d As Single ' Rotated 3D X (for backface culling)
y3d As Single ' Rotated 3D Y (for backface culling)
z3d As Single ' Rotated 3D Z (for backface culling)
End Type
' Global rotation angles (in degrees)
Dim rotationX As Single, rotationY As Single
rotationX = 0
rotationY = 0
Dim northInner(0 To nPhi - 1) As Vertex, northOuter(0 To nPhi - 1) As Vertex
Dim southInner(0 To nPhi - 1) As Vertex, southOuter(0 To nPhi - 1) As Vertex
Do
' Rotation control – arrow keys
If _KeyDown(18432) Then rotationX = rotationX - 3 ' Left arrow
If _KeyDown(20480) Then rotationX = rotationX + 3 ' Right arrow
If _KeyDown(19200) Then rotationY = rotationY - 3 ' Up arrow
If _KeyDown(19712) Then rotationY = rotationY + 3 ' Down arrow
Dim i As Integer, j As Integer
Dim phi1 As Single, phi2 As Single, theta1 As Single, theta2 As Single
Dim v1 As Vertex, v2 As Vertex, v3 As Vertex, v4 As Vertex
Dim avg As Single
' --- Before drawing, calculate the edge vertices for the poles ---
' For the northern pole:
' inner ring (closer to the pole) = vertices with ? = stepTheta/2
' outer ring = vertices with ? = stepTheta (which is the same as the first row of the middle band)
'
' For the southern pole:
' inner ring = vertices with ? = 180 - (stepTheta/2)
' outer ring = vertices with ? = 180 - stepTheta
For i = 0 To nPhi - 1
Dim phi As Single
phi = i * stepPhi
GetVertex northInner(i), phi, stepTheta / 2, rotationX, rotationY
GetVertex northOuter(i), phi, stepTheta, rotationX, rotationY
GetVertex southInner(i), phi, 180 - stepTheta / 2, rotationX, rotationY
GetVertex southOuter(i), phi, 180 - stepTheta, rotationX, rotationY
Next i
' --- Drawing the southern pole ---
Dim vPoleSouth As Vertex
GetVertex vPoleSouth, 0, 180, rotationX, rotationY
For i = 0 To nPhi - 1
Dim nextI As Integer
nextI = (i + 1) Mod nPhi
' 1. Triangles connecting the southern pole with the inner ring
_MapTriangle (vPoleSouth.u * texWidth, vPoleSouth.v * texHeight) - _
(southInner(i).u * texWidth, southInner(i).v * texHeight) - _
(southInner(nextI).u * texWidth, southInner(nextI).v * texHeight), _
myTexture To (vPoleSouth.sx, vPoleSouth.sy) - _
(southInner(i).sx, southInner(i).sy) - _
(southInner(nextI).sx, southInner(nextI).sy),0, _Smooth
' 2. Filling the square band between the inner and outer ring (divided into two triangles)
_MapTriangle (southInner(i).u * texWidth, southInner(i).v * texHeight) - _
(southOuter(i).u * texWidth, southOuter(i).v * texHeight) - _
(southOuter(nextI).u * texWidth, southOuter(nextI).v * texHeight), _
myTexture To (southInner(i).sx, southInner(i).sy) - _
(southOuter(i).sx, southOuter(i).sy) - _
(southOuter(nextI).sx, southOuter(nextI).sy),0, _Smooth
_MapTriangle (southInner(i).u * texWidth, southInner(i).v * texHeight) - _
(southOuter(nextI).u * texWidth, southOuter(nextI).v * texHeight) - _
(southInner(nextI).u * texWidth, southInner(nextI).v * texHeight), _
myTexture To (southInner(i).sx, southInner(i).sy) - _
(southOuter(nextI).sx, southOuter(nextI).sy) - _
(southInner(nextI).sx, southInner(nextI).sy),0, _Smooth
Next i
' --- Drawing the middle bands ---
For j = 1 To nTheta - 2
For i = 0 To nPhi - 1
phi1 = i * stepPhi
phi2 = (i + 1) * stepPhi
theta1 = j * stepTheta
theta2 = (j + 1) * stepTheta
Dim tu1 As Single, tu2 As Single, tu3 As Single
tu1 = v1.u: tu2 = v2.u: tu3 = v3.u
avg = (tu1 + tu2 + tu3) / 3
tu1 = AdjustUV(tu1, avg)
tu2 = AdjustUV(tu2, avg)
tu3 = AdjustUV(tu3, avg)
If IsFrontFace(v1, v2, v3) Then
_MapTriangle (tu1 * texWidth, v1.v * texHeight) - _
(tu2 * texWidth, v2.v * texHeight) - _
(tu3 * texWidth, v3.v * texHeight), _
myTexture To (v1.sx, v1.sy) - _
(v2.sx, v2.sy) - _
(v3.sx, v3.sy), 0,_Smooth
End If
tu1 = v2.u: tu2 = v4.u: tu3 = v3.u
avg = (tu1 + tu2 + tu3) / 3
tu1 = AdjustUV(tu1, avg)
tu2 = AdjustUV(tu2, avg)
tu3 = AdjustUV(tu3, avg)
If IsFrontFace(v2, v4, v3) Then
_MapTriangle (tu1 * texWidth, v2.v * texHeight) - _
(tu2 * texWidth, v4.v * texHeight) - _
(tu3 * texWidth, v3.v * texHeight), _
myTexture To (v2.sx, v2.sy) - _
(v4.sx, v4.sy) - _
(v3.sx, v3.sy),0, _Smooth
End If
Next i
Next j
' --- Drawing the northern pole (upper fan) – drawn only if it is visible ---
Dim vPoleNorth As Vertex
GetVertex vPoleNorth, 0, 0, rotationX, rotationY
If vPoleNorth.z3d < 0 Then
For i = 0 To nPhi - 1
nextI = (i + 1) Mod nPhi
' 1. Triangles connecting the northern pole with the inner ring
_MapTriangle (vPoleNorth.u * texWidth, vPoleNorth.v * texHeight) - _
(northInner(i).u * texWidth, northInner(i).v * texHeight) - _
(northInner(nextI).u * texWidth, northInner(nextI).v * texHeight), _
myTexture To (vPoleNorth.sx, vPoleNorth.sy) - _
(northInner(i).sx, northInner(i).sy) - _
(northInner(nextI).sx, northInner(nextI).sy),0, _Smooth
' 2. Filling the band between the inner and outer ring (two triangles)
_MapTriangle (northInner(i).u * texWidth, northInner(i).v * texHeight) - _
(northOuter(i).u * texWidth, northOuter(i).v * texHeight) - _
(northOuter(nextI).u * texWidth, northOuter(nextI).v * texHeight), _
myTexture To (northInner(i).sx, northInner(i).sy) - _
(northOuter(i).sx, northOuter(i).sy) - _
(northOuter(nextI).sx, northOuter(nextI).sy),0, _Smooth
_MapTriangle (northInner(i).u * texWidth, northInner(i).v * texHeight) - _
(northOuter(nextI).u * texWidth, northOuter(nextI).v * texHeight) - _
(northInner(nextI).u * texWidth, northInner(nextI).v * texHeight), _
myTexture To (northInner(i).sx, northInner(i).sy) - _
(northOuter(nextI).sx, northOuter(nextI).sy) - _
(northInner(nextI).sx, northInner(nextI).sy), 0,_Smooth
Next i
End If
_Limit 30
_Display
Loop Until _KeyDown(27) ' ESC exits the program
'------------------------------------------------------
' Function AdjustUV
'
' If the value of u differs from the average by more than 0.5,
' it adjusts it so that there is no discontinuity in the interpolation across the seam (u = 0 and u = 1).
' This is used only for the middle bands.
'------------------------------------------------------
Function AdjustUV (u As Single, avg As Single)
If u - avg > 0.5 Then
AdjustUV = u - 1
ElseIf u - avg < -0.5 Then
AdjustUV = u + 1
Else
AdjustUV = u
End If
End Function
'------------------------------------------------------
' SUB GetVertex
'
' Calculates a point on the unit sphere, determines texture coordinates,
' performs rotation (first around the Y axis, then around the X axis) and computes the 2D projection.
'
' For values ? = 0 and ? = 180, we set u and v fixed (i.e. u = 0.5, v = 0 respectively 1),
' which guarantees a smooth texture transition at the poles.
'------------------------------------------------------
Sub GetVertex (v As Vertex, phi As Single, theta As Single, rotX As Single, rotY As Single)
Dim radPhi As Single, radTheta As Single
radPhi = phi * (PI / 180)
radTheta = theta * (PI / 180)
Dim x0 As Single, y0 As Single, z0 As Single
x0 = Sin(radTheta) * Cos(radPhi)
y0 = Cos(radTheta)
z0 = Sin(radTheta) * Sin(radPhi)
If theta = 0 Then
v.u = 0.5
v.v = 0
ElseIf theta = 180 Then
v.u = 0.5
v.v = 1
Else
v.u = (_Atan2(z0, x0) + PI) / (2 * PI)
v.v = _Acos(y0) / PI
End If
Dim x As Single, y As Single, z As Single
x = x0: y = y0: z = z0
Dim ry As Single
ry = rotY * (PI / 180)
Dim xtemp As Single, ztemp As Single
xtemp = x * Cos(ry) + z * Sin(ry)
ztemp = -x * Sin(ry) + z * Cos(ry)
x = xtemp: z = ztemp
Dim rx As Single
rx = rotX * (PI / 180)
Dim ytemp As Single
ytemp = y * Cos(rx) - z * Sin(rx)
ztemp = y * Sin(rx) + z * Cos(rx)
y = ytemp: z = ztemp
v.x3d = x
v.y3d = y
v.z3d = z
v.sx = centerX + x * scale
v.sy = centerY - y * scale
End Sub
'------------------------------------------------------
' Function IsFrontFace
'
' Calculates the Z component of the normal (cross product) and determines whether the triangle is facing the camera.
' When viewed in the -Z direction, a triangle is front-facing if the normal is < 0.
'
' This is used for the middle bands.
'------------------------------------------------------
Function IsFrontFace (v1 As Vertex, v2 As Vertex, v3 As Vertex)
Dim edge1_x As Single, edge1_y As Single, edge1_z As Single
Dim edge2_x As Single, edge2_y As Single, edge2_z As Single
edge1_x = v2.x3d - v1.x3d
edge1_y = v2.y3d - v1.y3d
edge1_z = v2.z3d - v1.z3d
edge2_x = v3.x3d - v1.x3d
edge2_y = v3.y3d - v1.y3d
edge2_z = v3.z3d - v1.z3d
Dim norm_z As Single
norm_z = edge1_x * edge2_y - edge1_y * edge2_x
If Abs(norm_z) < 0.001 Then
IsFrontFace = -1 'bug! 0 causes Nort Pole and South Pole drawing error....
Exit Function
End If
If norm_z < 0 Then
IsFrontFace = -1
Else
IsFrontFace = 0
End If
End Function
