My Best Globe So Far - Printable Version

Code: (Select All)

_Title "Globe by SierraKen"

Screen _NewImage(800, 600, 32)

start:

t = 100 * (2 * _Pi)

cc = 50

w = 10

cc3 = 50



_Limit 20

While _MouseInput: Wend

If t < 0 Then GoTo start:

For l = -100 To 100 Step .025

    cc3 = cc3 + .1

    If cc3 > 255 Then cc3 = 50

    x = (Sin(t) * 100) * (_Pi / 2) + 400

    y = (Cos(t) * l) * (_Pi / 2) + 200

    t = t - (.25 + w / 10)

    PSet (x, y), _RGB32(cc3, cc3, 100 + cc3)

Next l

For l = -100 To 100 Step .025

    cc = cc + .1

    If cc > 255 Then cc = 50

    x = (Sin(t) * l) * (_Pi / 2) + 400

    y = (Cos(t) * 100) * (_Pi / 2) + 200

    t = t - (.25 + w / 10)

    PSet (x, y), _RGB32(cc, cc, 100 + cc)

Next l

t = t - .025

cc2 = 100

For sz = .1 To 100 Step .25

    cc2 = cc2 - .25

    Circle (400, 450), sz, _RGB32(100 + cc2, 100 + cc2, cc2), , , .5

Next sz

Line (400, 200)-(400, 450), _RGB32(255, 255, 255)

Do: Loop Until InKey$ = Chr$(27)

Code: (Select All)

_Title "Globe by SierraKen"

Option _Explicit ' mod by dcromley

Screen _NewImage(800, 600, 32)

Const n = 5000, qw = Sqr(.999997), qx = .001, qy = .001, qz = .001

Dim Shared As Single w, x, y, z, axyz(n, 3)

Dim As Single r, sz, cc2

Dim As Long i, rg



For i = 1 To n

  x = -1 + 2 * Rnd: y = -1 + 2 * Rnd: z = -1 + 2 * Rnd

  r = Sqr(x * x + y * y + z * z)

  axyz(i, 1) = 150 * x / r

  axyz(i, 2) = 150 * y / r

  axyz(i, 3) = 150 * z / r

Next i



Do

  _Limit 200

  Cls

  Line (400 - 86.6, 200 + 86.6)-(400 + 86.6, 200 - 86.6), _RGB32(128, 128, 128)

  For i = 1 To n

    rotate i

    rg = 255 * (150 + x + y + z) / 300

    PSet (400 + x, 200 - y), _RGB32(rg, rg, 255)

  Next i



  cc2 = 100

  For sz = .1 To 100 Step .25

    cc2 = cc2 - .25

    Circle (400, 450), sz, _RGB32(100 + cc2, 100 + cc2, cc2), , , .5

  Next sz

  Line (400, 200)-(400, 450), _RGB32(255, 255, 255)

  _Display

Loop While InKey$ <> Chr$(27)

System



Sub rotate (i As Long)

  Dim As Single ww, xx, yy, zz

  w = qw: x = qx: y = qy: z = qz

  qrotate w, x, y, z, 0, axyz(i, 1), axyz(i, 2), axyz(i, 3)

  qrotate w, x, y, z, qw, -qx, -qy, -qz

  axyz(i, 1) = x: axyz(i, 2) = y: axyz(i, 3) = z

End Sub



Sub qrotate (w, x, y, z, qw, qx, qy, qz)

  Dim As Single ww, xx, yy, zz

  ww = w * qw - x * qx - y * qy - z * qz

  xx = w * qx + x * qw + y * qz - z * qy

  yy = w * qy - x * qz + y * qw + z * qx

  zz = w * qz + x * qy - y * qx + z * qw

  w = ww: x = xx: y = yy: z = zz

End Sub