08-20-2023, 09:55 PM
(This post was last modified: 08-21-2023, 01:59 PM by James D Jarvis.)
an update of an older sub to draw filled polygons using _maptriangle . This one is faster than the earlier version (polyT) and includes options for rotation, horizontal and vertical scaling, and a border.
Code: (Select All)
'draw_polyFT ' by James D. Jarvis , August 20,2023 'draw filled polygons ' 'HEADER Dim Shared xmax, ymax xmax = 800: ymax = 500 Screen _NewImage(xmax, ymax, 32) Dim Shared pk& 'must be included in a program that uses polyFT pk& = _NewImage(3, 3, 32) 'must be included in a program that uses polyFT '====================================== ' demo '====================================== ' This demo draws 64000 random polygons, and then clears the screen and draws a handful of polygons rotating Randomize Timer t1 = Timer For reps = 1 To 64000 polyFT Int(Rnd * xmax), Int(Rnd * ymax), Int(3 + Rnd * 20), Int(3 + Rnd * 12), Int(Rnd * 60), Int(1 + Rnd * 3), Int(1 + Rnd * 3), _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256)), _RGB32(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256)) Next reps t2 = Timer Print "That took "; t2 - t1; " seconds to draw 64000 polygons" Sleep rtn = 0 Do _Limit 60 Cls Print "Press <ESC> to quit>" polyFT 100, 100, 40, 3, rtn, 1, 1, _RGB32(100, 200, 50), 0 polyFT 200, 100, 40, 4, 45 + rtn, 1, 1, _RGB32(100, 200, 250), 0 polyFT 300, 100, 40, 5, rtn, 1, 1, _RGB32(200, 100, 250), 0 polyFT 400, 100, 40, 6, rtn, 1, 1, _RGB32(100, 250, 150), 0 polyFT 500, 100, 40, 7, rtn, 1, 1, _RGB32(150, 200, 200), 0 polyFT 600, 100, 40, 8, 22.5 + rtn, 1, 1, _RGB32(200, 200, 0), 0 _PrintString (100 - (_PrintWidth("Triangle")) / 2, 160), "Triangle" _PrintString (200 - (_PrintWidth("Square")) / 2, 160), "Square" _PrintString (300 - (_PrintWidth("Pentagon")) / 2, 160), "Pentagon" _PrintString (400 - (_PrintWidth("Hexagon")) / 2, 160), "Hexagon" _PrintString (500 - (_PrintWidth("Heptagon")) / 2, 160), "Heptagon" _PrintString (600 - (_PrintWidth("Octagon")) / 2, 160), "Octagon" rtn = rtn + 1: If rtn > 360 Then rtn = 0 _Display 'for smooth display Loop Until InKey$ = Chr$(27) '========================================================================== 'subroutines ' ' polyFT draw a filled polygon ' ' setklr is a sub to build the color image used by triangles in polyFT '====================================== ================================== Sub polyFT (cx As Long, cy As Long, rad As Long, sides As Integer, rang As Long, ww, vv, klr As _Unsigned Long, lineyes As _Unsigned Long) 'draw an equilateral polygon using filled triangle for each segment 'centered at cx,cy to radius rad of sides # of face rotated to angle rang scaled to ww and vv of color klr and lineyes if there is an outline, a value 0 would create no outline setklr klr Dim px(sides) Dim py(sides) pang = 360 / sides ang = 0 For p = 1 To sides px(p) = cx + (rad * Cos(0.01745329 * (ang + rang))) * ww py(p) = cy + (rad * Sin(0.01745329 * (ang + rang))) * vv ang = ang + pang Next p For p = 1 To sides - 1 _MapTriangle (0, 0)-(0, 2)-(2, 0), pk& To(cx, cy)-(px(p), py(p))-(px(p + 1), py(p + 1)) If lineyes > 0 Then Line (px(p), py(p))-(px(p + 1), py(p + 1)), lineyes Next p _MapTriangle (0, 0)-(0, 2)-(2, 0), pk& To(cx, cy)-(px(sides), py(sides))-(px(1), py(1)) If lineyes > 0 Then Line (px(sides), py(sides))-(px(1), py(1)), lineyes End Sub Sub setklr (klr As Long) 'internal routine to setup an image to copy a colored triangle from in the color klr 'called by polyT _Dest pk& Line (0, 0)-(2, 2), klr, BF _Dest 0 End Sub
