Happy New Year Globe! - Printable Version

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