Polygon playground

[bplus]

2+ Years later

Code: (Select All)

Option _Explicit
_Title "Star Worlds" 'B+ 2019-11-26

Const xmax = 1200, ymax = 700, nS = 500
Type starType
    x As Single
    y As Single
    dx As Single
    dy As Single
    ri As Single
    ro As Single
    nP As Integer
    aOff As Single
    da As Single
    filled As Integer
    cc As _Unsigned Long
End Type
Dim Shared stars(1 To nS) As starType

Randomize Timer
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
Dim i As Integer

For i = 1 To nS
    newStar i
Next
While _KeyDown(27) = 0
    Line (0, 0)-(xmax, ymax), _RGBA32(0, 0, 0, 30), BF
    For i = 1 To nS
        drawStar i
        stars(i).x = stars(i).x + stars(i).dx: stars(i).y = stars(i).y + stars(i).dy
        If stars(i).x < -50 Or stars(i).x > xmax + 50 Or stars(i).y < -50 Or stars(i).y > ymax + 50 Then newStar i
        stars(i).aOff = stars(i).aOff + stars(i).da
    Next
    _Display
    _Limit 60
Wend

Sub newStar (i)
    stars(i).x = irnd%(0, xmax)
    stars(i).y = irnd%(0, ymax)
    stars(i).ri = irnd%(1, 6)
    stars(i).ro = stars(i).ri * (Rnd * 10 + 1.5)
    stars(i).nP = irnd%(3, 12)
    stars(i).aOff = Rnd * _Pi(2)
    If Rnd < .5 Then stars(i).da = Rnd * _Pi / -45 Else stars(i).da = Rnd * _Pi / 45
    stars(i).filled = irnd%(0, 1)
    stars(i).dx = irnd%(-10, 10)
    stars(i).dy = irnd%(-10, 10)
    stars(i).cc = _RGBA32(irnd%(128, 255), irnd%(128, 255), irnd%(128, 255), irnd%(1, 255))
End Sub

Function irnd% (n1, n2) 'return an integer between 2 numbers
    Dim l%, h%
    If n1 > n2 Then l% = n2: h% = n1 Else l% = n1: h% = n2
    irnd% = Int(Rnd * (h% - l% + 1)) + l%
End Function

Sub fIrrPoly (arr() As Single, c As _Unsigned Long)
    'this just draws a bunch of triangles according to x, y points in arr()
    Dim ox As Single, oy As Single, i As Integer
    ox = arr(0): oy = arr(1) 'the first 2 items in arr() need to be center
    For i = 2 To UBound(arr) - 3 Step 2
        ftri ox, oy, arr(i), arr(i + 1), arr(i + 2), arr(i + 3), c
    Next
End Sub

Sub drawStar (i As Integer)
    ' x, y are same as for circle,
    ' rInner is center circle radius
    ' rOuter is the outer most point of star
    ' nPoints is the number of points,
    ' angleOffset = angle offset in radians
    ' this is to allow us to spin the star
    Dim pAngle As Single, radAngleOffset As Single, p As Integer, idx As Integer
    Dim ar(Int(stars(i).nP) * 4 + 3) As Single 'add two for origin

    pAngle = _Pi(2) / stars(i).nP: radAngleOffset = stars(i).aOff - _Pi(1 / 2)
    ar(0) = stars(i).x: ar(1) = stars(i).y
    ar(2) = stars(i).x + stars(i).ro * Cos(radAngleOffset)
    ar(3) = stars(i).y + stars(i).ro * Sin(radAngleOffset)
    idx = 4
    For p = 0 To stars(i).nP - 1
        ar(idx) = stars(i).x + stars(i).ri * Cos(p * pAngle + radAngleOffset + .5 * pAngle)
        idx = idx + 1
        ar(idx) = stars(i).y + stars(i).ri * Sin(p * pAngle + radAngleOffset + .5 * pAngle)
        idx = idx + 1
        ar(idx) = stars(i).x + stars(i).ro * Cos((p + 1) * pAngle + radAngleOffset)
        idx = idx + 1
        ar(idx) = stars(i).y + stars(i).ro * Sin((p + 1) * pAngle + radAngleOffset)
        idx = idx + 1
    Next
    If stars(i).filled Then
        fIrrPoly ar(), stars(i).cc
    Else
        For p = 2 To stars(i).nP * 4 + 3 Step 2
            If p > 2 Then Line (ar(p - 2), ar(p - 1))-(ar(p), ar(p + 1)), stars(i).cc
        Next
    End If
End Sub

Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim D As Long
    Static a&
    D = _Dest
    If a& = 0 Then a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest D
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub