Polygon playground

[Dav]

Had a small Polygon drawing SUB handy, thought I'd make a screen saver using it.  You can specify the number of sides, radius, angle, border and fill color of polygon.  Maybe useful to somebody.

UPDATED:  Now draws filled polygons.

- Dav

Code: (Select All)

'=====================

'PolygonPlayground.bas v2.0

'=====================

'A single SUB that draws a polygon, filled or not..

'Specify number of sides, radius, angle, border and fill color of polygon.

'Put together by Dav, AUG/2024



'This demo shows the SUB in action.





Screen _NewImage(1000, 700, 32)



Randomize Timer



polygons = 200 'number of polgons in playground



Dim polysides(polygons)

Dim polyradius(polygons)

Dim polyclr&(polygons)

Dim polycx(polygons)

Dim polycy(polygons)



'make random polgons specs



For i = 1 To polygons

    polysides(i) = 3 + Int(Rnd * 10)

    polyradius(i) = 30 + Int(Rnd * 150)

    polyclr&(i) = _RGBA(Rnd * 255, Rnd * 255, Rnd * 255, Rnd * 255)

    'turn some of those no fill  (zero value)

    If Int(Rnd * 5) = 1 Then polyclr&(i) = 0

    polycx(i) = Rnd * _Width

    polycy(i) = Rnd * _Height

Next





Do

    'spin them all it around

    For a = 0 To 359

        Cls , _RGB(255, 255, 255)

        For i = 1 To polygons

            Polygon polysides(i), polycx(i), polycy(i), polyradius(i), a, _RGBA(0, 0, 0, 128), polyclr&(i)

        Next

        _Display

        _Limit 60

        If InKey$ <> "" Then Exit Do

    Next

Loop









Sub Polygon (sides, cx, cy, radius, angle, borderclr~&, fillclr~&)

    'Draws a polygon. Must have at least 3 sides.

    'Polygon can be filled or not.

    'borderclr~& is the color of the polygon sides.

    'if you want a filled polygon, give a fillclr~& color.

    'if you want only sides drawn (not filled polygon),

    'just use a 0 for the fillclr~& parameter.



    If sides < 3 Then sides = 3



    rot = _D2R(angle)



    x1 = cx + radius * Cos(rot)

    y1 = cy + radius * Sin(rot)

    'draw sides

    For i = 1 To sides

        va = rot + 2 * _Pi * i / sides

        x2 = cx + radius * Cos(va)

        y2 = cy + radius * Sin(va)

        Line (x1, y1)-(x2, y2), borderclr~&

        x1 = x2: y1 = y2

    Next

    'fill inside, if not 0 given

    If fillclr~& <> 0 Then

        ymin = cy - radius

        ymax = cy + radius

        For y = ymin To ymax

            edge = 0

            x1 = cx + radius * Cos(rot)

            y1 = cy + radius * Sin(rot)

            For i = 1 To sides

                va = rot + 2 * _Pi * i / sides

                x2 = cx + radius * Cos(va)

                y2 = cy + radius * Sin(va)

                If ((y1 < y And y2 >= y) Or (y2 < y And y1 >= y)) Then

                    edge = edge + 1

                    If edge = 1 Then

                        leftx = x1 + (y - y1) * (x2 - x1) / (y2 - y1)

                    ElseIf edge = 2 Then

                        rightx = x1 + (y - y1) * (x2 - x1) / (y2 - y1)

                    End If

                End If

                x1 = x2: y1 = y2

            Next

            If edge = 2 Then Line (leftx, y)-(rightx, y), fillclr~&

        Next

    End If

End Sub

[Dav]

I updated the Polygon SUB, it also can now draw filled polygons if you want.  Just give fillclr~& a color value to use.  If you want the polygon empty (not filled) give the fillclr~& value a 0 instead.  The polygon sides color (borderclr~&) and the polygons fill in color can be different if you want. 

- Dav

   

[bplus]

7 years ago I was doing polygons!

Code: (Select All)

_Title "Polygon Demo by bplus"
' polygon demo.bas for QB64 (B+=MGA) 2017-09-17
Const xmax = 700
Const ymax = 700

Screen _NewImage(xmax, ymax, 32)
_Delay .25
_ScreenMove _Middle

x0 = xmax / 2: y0 = ymax / 2
For n = 3 To 9
    radius = 345
    Cls
    rr = Rnd * 75: gg = Rnd * 75: bb = Rnd * 75
    For a = 0 To _Pi(2) Step _Pi(1 / 20)
        radius = radius - 8
        pc& = _RGB(radius / 345 * 200 + rr, radius / 345 * 200 + gg, radius / 345 * 200 + bb)
        Color pc&
        polygon x0, y0, radius, n, a
        Paint (x0, y0), pc&, pc&
        _Limit 10
    Next
    Sleep 2
Next

Sub polygon (xOrigin, yOrigin, radius, nVertex, RadianAngleOffset)
    polyAngle = _Pi(2) / nVertex
    x1 = xOrigin + radius * Cos(polyAngle + RadianAngleOffset)
    y1 = yOrigin + radius * Sin(polyAngle + RadianAngleOffset)
    For i = 2 To nVertex + 1
        x2 = xOrigin + radius * Cos(i * polyAngle + RadianAngleOffset)
        y2 = yOrigin + radius * Sin(i * polyAngle + RadianAngleOffset)
        Line (x1, y1)-(x2, y2)
        x1 = x2: y1 = y2
    Next
End Sub

Looks like I was filling with Paint back then, later versions I filled with fTri (Filled Triangles) way way faster! Plus could then do transparent colors.

[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

[Dav]

Yes, those are nice. I remember seeing the star one.

 - Dav

[RokCoder]

Polygons! Very nicely done! I needed similar (rotated n-sided polygons) in my Poly Blaster game but opted for very badly implemented Open GL code to do it for performance reasons. This is a much more fun approach.