3D Orbiting Text - Printable Version

Code: (Select All)
'3D Orbiting Text by SierraKen

'Made on August 2, 2022.

'Thanks to Steve for the font array idea!



Dim starx(1000), stary(1000)

Dim dx(1000), dy(1000)

Dim sz(1000)

Dim speed(1000)

Dim cx As Integer, cy As Integer, ra As Integer, cl As _Unsigned Long

Dim Font(8) As Long



_Title "3D Orbiting Text by SierraKen - Press Space Bar to restart"

Screen _NewImage(800, 600, 32)



Font(0) = _LoadFont("Comic.ttf", 10)

Font(1) = _LoadFont("Comic.ttf", 12)

Font(2) = _LoadFont("Comic.ttf", 14)

Font(3) = _LoadFont("Comic.ttf", 16)

Font(4) = _LoadFont("Comic.ttf", 18)

Font(5) = _LoadFont("Comic.ttf", 22)

Font(6) = _LoadFont("Comic.ttf", 24)

Font(7) = _LoadFont("Comic.ttf", 26)



start:

f = 5

_Font Font(f)

t = 1800

x = 400: y = 300: r = 50

t2 = 1800

cc4 = 100

cc5 = 100

Cls

start2:

Color _RGB32(255, 255, 255)

Print: Print

Print "Type any 5 letter or less word, number, or characters: "

Input text$

Print: Print

If Len(text$) > 5 Then Print "Too long, try again.": GoTo start2:

If Len(text$) < 1 Then Print "You didn't type anything, try again.": GoTo start2:

Cls



Do

    _Limit 20

    a$ = InKey$

    If a$ = Chr$(27) Then End

    If a$ = " " Then GoTo start:



    'Starfield

    fillCircle cx, cy, 5, cl

    If sp < .0005 Then sp = .0005

    If sp > .1 Then sp = .1

    warp = (sp * 100) + 1

    If warp > 10 Then warp = 10

    warp = Int(warp)

    stars = Int(Rnd * 100) + 1

    If stars > 25 Then

        ss = ss + 1

        If ss > 950 Then ss = 1

        'Set starting position.

        startx = Rnd * 490

        starty = Rnd * 390

        st = Int(Rnd * 360)

        xx = (Sin(st) * startx) + 400

        yy = (Cos(st) * starty) + 300

        starx(s) = xx

        stary(s) = yy

        'Set direction to move.

        dx(s) = ((xx - 400) / 30)

        dy(s) = ((yy - 300) / 30)

        'Set size.

        sz(s) = Rnd

        'Set speed

        speed(s) = .1

    End If

    If yy > 640 Then yy = 0

    For tt = 1 To 950

        speed(tt) = speed(tt) * (1.05 + sp)

        stary(tt) = stary(tt) + dy(tt) * speed(tt)

        starx(tt) = starx(tt) + dx(tt) * speed(tt)

        cx = starx(tt): cy = stary(tt)

        ra = sz(tt) + .5

        cl = _RGB32(255, 255, 255)

        fillCircle cx, cy, ra, cl

        'skip:

    Next tt



    If t < 90 Then t = 1800

    If t2 < 90 Then t2 = 1800

    oldx3 = x3

    x2 = (Sin(t) * 360) + 400

    y2 = (Cos(t) * 180) / _Pi / 1.55 + 300

    r2 = (Cos(t) * 180) / _Pi / 1.55 + 50

    x3 = (Sin(t2) * r2 * (y3 / y2) * _Pi) + x2

    y3 = (Cos(t2) * 80) / _Pi / 2 + y2

    r3 = (Cos(t2) * 20) / _Pi / 1.5 + r2 / 5

    t = t - .025

    t2 = t2 - .3

    If r2 < 20 Then f = 0

    If r2 < 30 And r2 >= 20 Then f = 1

    If r2 < 40 And r2 >= 30 Then f = 2

    If r2 < 50 And r2 >= 40 Then f = 3

    If r2 < 60 And r2 >= 50 Then f = 4

    If r2 < 70 And r2 >= 60 Then f = 5

    If r2 < 80 And r2 >= 70 Then f = 6

    If r2 >= 80 Then f& = 7

    _Font Font(f)



    If y2 < 290 Then

        'Text

        _PrintString (x2 - 30, y2), text$

        'Moon

        cc4 = 200

        For s = .25 To r3 Step .25

            cc4 = cc4 - 2

            Circle (x3, y3), s, _RGB32(cc4, cc4, cc4)

        Next s

        cc4 = 0

    End If

    'Sun

    For sun = .25 To 35 Step .25

        cc2 = cc2 + 1

        Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)

    Next sun

    cc2 = 0

    If y2 >= 290 Then

        'Text

        _PrintString (x2 - 30, y2), text$

        'Moon

        cc5 = 200

        For s = .25 To r3 Step .25

            cc5 = cc5 - 2

            Circle (x3, y3), s, _RGB32(cc5, cc5, cc5)

        Next s

        cc5 = 0

        If y3 < y2 Then

            'Text

            _PrintString (x2 - 30, y2), text$

        End If

    End If

    If x3 > oldx3 And y2 < 290 And (Point(x3 + r3 + 1, y3) <> _RGB32(0, 0, 0) Or Point(x3 + r3 + 1, y3)) <> _RGB32(255, 255, 255) Then

        'Text

        _PrintString (x2 - 30, y2), text$

        'Sun

        For sun = .25 To 35 Step .25

            cc2 = cc2 + 1

            Circle (x, y), sun, _RGB32(255 - cc2, 255 - cc2, 128 - cc2)

        Next sun

        cc2 = 0

    End If

    _Delay .05

    _Display

    Cls

Loop



'from Steve Gold standard

Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)

    Dim Radius As Integer, RadiusError As Integer

    Dim X As Integer, Y As Integer

    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0

    If Radius = 0 Then PSet (CX, CY), C: Exit Sub

    Line (CX - X, CY)-(CX + X, CY), C, BF

    While X > Y

        RadiusError = RadiusError + Y * 2 + 1

        If RadiusError >= 0 Then

            If X <> Y + 1 Then

                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF

                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF

            End If

            X = X - 1

            RadiusError = RadiusError - X * 2

        End If

        Y = Y + 1

        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF

        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF

    Wend

End Sub