+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Polygon playground (/showthread.php?tid=2991)
Polygon playground - Dav - 08-28-2024
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 SubRE: Polygon playground - Dav - 09-01-2024
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
RE: Polygon playground - bplus - 09-01-2024
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 SubLooks 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.
RE: Polygon playground - bplus - 09-01-2024
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 SubRE: Polygon playground - Dav - 09-01-2024
Yes, those are nice. I remember seeing the star one.
- Dav