Rotating Globe

[SMcNeill]

Code: (Select All)

_Title "Rotating Sphere in QB64PE"
Screen _NewImage(800, 600, 32)
Dim Shared sphere(360, 360) As _Unsigned Long
Dim Shared rotationX, rotationY As Single

' Initialize the sphere
For phi = 0 To 359
    For theta = 0 To 359
        x = Cos(_D2R(phi)) * Sin(_D2R(theta))
        y = Sin(_D2R(phi)) * Sin(_D2R(theta))
        z = Cos(_D2R(theta))
        sphere(phi, theta) = _RGB32(Cos(_D2R(phi)) * 127 + 128, Sin(_D2R(phi)) * 127 + 128, z * 127 + 128)
    Next
Next

' Main loop
Do
    If _KeyDown(18432) Then rotationX = rotationX - 5
    If _KeyDown(20480) Then rotationX = rotationX + 5
    If _KeyDown(19200) Then rotationY = rotationY - 5
    If _KeyDown(19712) Then rotationY = rotationY + 5
    Cls , 0
    _PrintString (0, 0), "Rotating Rainbow Sphere"
    _PrintString (0, 16), "Use arrow keys to rotate"

    ' Draw the sphere
    For phi = 0 To 359 Step .25
        For theta = 0 To 359 Step .25
            x = Cos(_D2R(phi)) * Sin(_D2R(theta))
            y = Sin(_D2R(phi)) * Sin(_D2R(theta))
            z = Cos(_D2R(theta))

            ' 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

    _Display
    _Limit 60
Loop Until _KeyDown(27)

Now I just need to sort out how to read a 2d map and convert it up to 3d coordinates, and I'll be able to rotate the earth for a program.

Anyone want to take on that part of the fun?

[Petr]

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

[Jack]

@Petr
where is 6.jpg ?

[Petr]

Insert any photo there

[Jack]

Ok

[a740g]

I remember seeing something similar by Terry here: https://qb64phoenix.com/forum/showthread.php?tid=3020

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

Screen _NewImage(800, 600, 32)
myTexture = _LoadImage("z:\earth.bmp")
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 ' 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 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 ' Projekcní X na obrazovce            Projection X on screen
    sy As Integer ' Projekcní Y na obrazovce            Projection Y on screen
    u As Single ' Texturovací souradnice U (0 až 1)      Texturing coordinate U 0 to 1
    v As Single ' Texturovací souradnice V (0 až 1)      Texturing coordinate V 0 to 1
    x3d As Single ' Otocená 3D souradnice X              rotation 3D X
    y3d As Single ' Otocená 3D souradnice Y              rotation 3D Y
    z3d As Single ' 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)

' Globální rotacní úhly (v°
' (Global rotation angles in degrees)
Dim rotationX As Single, rotationY As Single
rotationX = 0
rotationY = 0

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)

    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 (ctverec) rozdelí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ý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)
            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
    _Limit 30
    _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.)
'------------------------------------------------------
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)

    ' Puvodní (neotocený 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ý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 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í 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.)
'------------------------------------------------------
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
    ' 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 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

   

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

[Pete]

Neat! Now I can see the Gulf of America from my back porch.

Pete  

- I'm a Global-Least.

[Petr]

I'm working on it.

[Petr]

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
 
    Cls , 0
    _PrintString (0, 0), "Rotating textured sphere with backface culling"
    _PrintString (0, 16), "Use the arrow keys. ESC to exit."
    _PrintString (0, 32), "rotationX = " + Str$(rotationX) + "  rotationY = " + Str$(rotationY)
 
    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
 
            GetVertex v1, phi1, theta1, rotationX, rotationY
            GetVertex v2, phi2, theta1, rotationX, rotationY
            GetVertex v3, phi1, theta2, rotationX, rotationY
            GetVertex v4, phi2, theta2, rotationX, rotationY
 
            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