+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Utilities (https://staging.qb64phoenix.com/forumdisplay.php?fid=8)
+---- Thread: draw_polyT (Polygons) (/showthread.php?tid=840)
draw_polyT (Polygons) - James D Jarvis - 09-02-2022
draw filled equilateral polygons and circles using _MapTriangle
Code: (Select All)
'draw_polyT
' by James D. Jarvis
'draw filled equilateral polygons and circles
'
'HEADER
Dim Shared xmax, ymax
xmax = 800: ymax = 500
Screen _NewImage(xmax, ymax, 32)
Dim Shared pk&
pkt& = _NewImage(3, 3, 32)
'======================================
' demo
'======================================
Randomize Timer
Dim degr(10) As Long 'just to ahve a clean demonstration of randomly defiend shapes
degr(1) = 1
degr(2) = 3
degr(3) = 12
degr(4) = 30
degr(5) = 40
degr(6) = 45
degr(7) = 60
degr(8) = 72
degr(9) = 90
degr(10) = 120
t1 = Timer
For reps = 1 To 64000
polyT Int(Rnd * xmax), Int(Rnd * ymax), Int(10 + Rnd * 60), _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256)), degr(Int(1 + Rnd * 10))
Next reps
t2 = Timer
Print "That took "; t2 - t1; " seconds to draw 64000 polygons"
'==========================================================================
'subroutines
'
' polyT draw a filled equilateral polygon or circle
'
' setklr is an sub to build the color image used byt triangles in polyT
'====================================== ==================================
Sub polyT (cx As Long, cy As Long, r As Long, klr As _Unsigned Long, deg As Long)
'draw an equilateral polygon
'if degrees dont' evenly divide into 360 it's goign to be ragged.
'circles will be drawn when the value for degree is low
setklr klr
d = 0
x = r * Sin(0)
y = r * Cos(0)
While d < 360
d = d + deg
x2 = r * Sin(0.01745329 * d)
y2 = r * Cos(0.01745329 * d)
_MapTriangle (0, 2)-(2, 2)-(2, 0), pk& To(cx, cy)-(cx + x, cy + y)-(cx + x2, cy + y2)
x = x2
y = y2
Wend
End Sub
Sub setklr (klr As Long)
'setup a image to copy a colored triangle
'called by polyT
_Dest pk&
Line (0, 0)-(2, 2), klr, BF
_Dest 0
End Sub