DNA Animation

[Kernelpanic]

Looks good! Shows what one can do with Basic if one it can.

Some color for the DNA.  Unfortunately, some colors are displayed incorrectly.

Code: (Select All)

'Etwas Farbe fuer die DNA ;) - 31. Juli 2022

'DNA Animation by SierraKen
'Ball design by B+ and OldMoses
'July 31, 2022

_Title "DNA Animation by SierraKen"

Screen _NewImage(800, 600, 32)

Dim red, green, yellow, pink, blue, c As Long


t = 180
tt = 45

c = _RGB32(0, 127, 255)
red = _RGB32(255, 0, 0)
green = _RGB32(0, 204, 0)
yellow = _RGB32(255, 255, 0)
pink = _RGB32(255, 102, 255)
lila = _RGB32(127, 0, 255)
blue = _RGB32(153, 51, 255)



Do
  _Limit 40
  x = (Sin(t) * 180) + 400
  y = (Cos(t) * 180) / _Pi / 10 + 100
  r = (Cos(t) * 180) / _Pi / 10 + 40

  x2 = (Sin(t + .7) * 180) + 400
  y2 = (Cos(t + .7) * 180) / _Pi / 10 + 165
  r2 = (Cos(t + .7) * 180) / _Pi / 10 + 40

  x3 = (Sin(t + 1.4) * 180) + 400
  y3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 230
  r3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 40

  x4 = (Sin(t + 2.1) * 180) + 400
  y4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 295
  r4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 40

  x5 = (Sin(t + 2.8) * 180) + 400
  y5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 360
  r5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 40

  x6 = (Sin(t + 3.5) * 180) + 400
  y6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 425
  r6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 40

  xx = (Sin(tt) * 180) + 400
  yy = (Cos(tt) * 180) / _Pi / 10 + 100
  rr = (Cos(tt) * 180) / _Pi / 10 + 40

  xx2 = (Sin(tt + .7) * 180) + 400
  yy2 = (Cos(tt + .7) * 180) / _Pi / 10 + 165
  rr2 = (Cos(tt + .7) * 180) / _Pi / 10 + 40

  xx3 = (Sin(tt + 1.4) * 180) + 400
  yy3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 230
  rr3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 40

  xx4 = (Sin(tt + 2.1) * 180) + 400
  yy4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 295
  rr4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 40

  xx5 = (Sin(tt + 2.8) * 180) + 400
  yy5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 360
  rr5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 40

  xx6 = (Sin(tt + 3.5) * 180) + 400
  yy6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 425
  rr6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 40

  t = t - .05
  tt = tt - .05

  If rr > r Then
    cx = x: cy = y
    drawBall cx, cy, r, red

    cx = xx: cy = yy
    drawBall cx, cy, rr, green
  End If

  If rr < r Then
    cx = xx: cy = yy
    drawBall cx, cy, rr, yellow
    cx = x: cy = y
    drawBall cx, cy, r, c

  End If

  If rr2 > r2 Then
    cx = x2: cy = y2
    drawBall cx, cy, r2, c

    cx = xx2: cy = yy2
    drawBall cx, cy, rr2, c
  End If

  If rr2 < r2 Then
    cx = xx2: cy = yy2
    drawBall cx, cy, rr2, c
    cx = x2: cy = y2
    drawBall cx, cy, r2, c
  End If

  If rr3 > r3 Then
    cx = x3: cy = y3
    drawBall cx, cy, r3, lila
    cx = xx3: cy = yy3
    drawBall cx, cy, rr3, pink
  End If
  If rr3 < r3 Then
    cx = xx3: cy = yy3
    drawBall cx, cy, rr3, c
    cx = x3: cy = y3
    drawBall cx, cy, r3, c
  End If

  If rr4 > r4 Then
    cx = x4: cy = y4
    drawBall cx, cy, r4, c
    cx = xx4: cy = yy4
    drawBall cx, cy, rr4, c
  End If
  If rr4 < r4 Then
    cx = xx4: cy = yy4
    drawBall cx, cy, rr4, c
    cx = x4: cy = y4
    drawBall cx, cy, r4, c
  End If

  If rr5 > r5 Then
    cx = x5: cy = y5
    drawBall cx, cy, r5, green

    cx = xx5: cy = yy5
    drawBall cx, cy, rr5, red
  End If

  If rr5 < r5 Then
    cx = xx5: cy = yy5
    drawBall cx, cy, rr5, c
    cx = x5: cy = y5
    drawBall cx, cy, r5, c
  End If


  If rr6 > r6 Then
    cx = x6: cy = y6
    drawBall cx, cy, r6, c

    cx = xx6: cy = yy6
    drawBall cx, cy, rr6, c
  End If

  If rr6 < r6 Then
    cx = xx6: cy = yy6
    drawBall cx, cy, rr6, yellow
    cx = x6: cy = y6
    drawBall cx, cy, r6, c
  End If

  _Display
  Cls
Loop Until InKey$ = Chr$(27)


Sub drawBall (x, y, r, c As _Unsigned Long)
  Dim rred As Long, grn As Long, blu As Long, rr As Long, f
  rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
  For rr = r To 0 Step -1
    f = 1 - Sin(rr / r)
    fillCircle x, y, rr, _RGB32(rred * f, grn * f, blu * f)
  Next
End Sub


'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