As promised Regular Polygons Filled without any Alpha color problems PLUS the TriFill is a Drawing Utility worth the price of admission in itself!!!
First we draw random sets or Regular Polys Filled, use any key for another set, and escape to see the Spin Demo use x to quit that.
Correction (2022-10-16): Though not used here, I forgot to change the color of the first point drawn in Sub for drawing regular polygons, fixed now.
First we draw random sets or Regular Polys Filled, use any key for another set, and escape to see the Spin Demo use x to quit that.
Code: (Select All)
Option _Explicit
_Title "Sub for Regular Polygon Fill Using Degrees" 'b+ 2022-10-13
Screen _NewImage(800, 600, 32) ' standard screen size 800 wide, 600 height for quick QB64 Demos with full color potential (the 32)
_ScreenMove 250, 50
Dim i
' Give RegularPolygonFill sub a random workout
Do
Cls
For i = 1 To 50
RegularPolyFill Rnd * _Width, Rnd * _Height, Rnd * 100 + 5, Int(Rnd * 10) + 3, Rnd * 360, _RGB32(225 * Rnd + 30, 255 * Rnd, 255 * Rnd, 225 * Rnd + 30)
Next
Print "zzz... Esc for next demo, any other for another Random set."
Sleep
Loop Until _KeyDown(27)
'lets take a set for a spin, User Defined Type (UDT) some poly's
Type poly
As Single x, y, r, p, dStart, rDir, deltaD, s
As _Unsigned Long k
End Type
Dim pf(1 To 100) As poly ' poly array to load
For i = 1 To 100 ' makeup a bunch of poly data
pf(i).x = Rnd * _Width
pf(i).y = Rnd * _Height
pf(i).r = Rnd * 100 + 5 ' radius
pf(i).p = Int(Rnd * 10) + 3 ' n points
pf(i).dStart = Rnd * 360 ' start angle of polygon
If Rnd < .5 Then pf(i).rDir = -1 Else pf(i).rDir = 1 ' direction to spin
pf(i).deltaD = Rnd * 10 + .5 ' spin amount
pf(i).k = _RGB32(225 * Rnd + 30, 255 * Rnd, 255 * Rnd, 225 * Rnd + 30) ' Kolor
Next
Do
Cls
For i = 1 To 100
RegularPolyFill pf(i).x, pf(i).y, pf(i).r, pf(i).p, pf(i).dStart, pf(i).k
pf(i).dStart = pf(i).dStart + pf(i).rDir * pf(i).deltaD
Next
Print "Use x to quit..."
_Display ' stops blinking
_Limit 30 ' loop at most 30 times a sec
Loop Until _KeyDown(Asc("x"))
Sub RegularPolyFill (cx, cy, radius, nPoints, dStart, K As _Unsigned Long)
Dim secDegrees, p, x, y, lastX, lastY, startX, startY
secDegrees = 360 / nPoints
For p = 1 To nPoints
x = cx + radius * CosD(dStart + p * secDegrees)
y = cy + radius * SinD(dStart + p * secDegrees)
If p > 1 Then
TriFill cx, cy, lastX, lastY, x, y, K
Else
startX = x: startY = y
End If
lastX = x: lastY = y
Next
TriFill cx, cy, lastX, lastY, startX, startY, K ' back to first point
End Sub
Sub RegularPoly (cx, cy, radius, nPoints, dStart, K As _Unsigned Long)
Dim secDegrees, p, x, y, saveX, saveY
secDegrees = 360 / nPoints
For p = 1 To nPoints
x = cx + radius * CosD(dStart + p * secDegrees)
y = cy + radius * SinD(dStart + p * secDegrees)
If p = 1 Then PSet (x, y), K: saveX = x: saveY = y Else Line -(x, y), K
Next
Line -(saveX, saveY), K ' back to first point
End Sub
' use angles in degrees units instead of radians (converted inside sub)
Function CosD (degrees)
' Note this function uses whatever the default type is, better not be some Integer Type.
CosD = Cos(_D2R(degrees))
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function SinD (degrees)
' Note this function uses whatever the default type is, better not be some Integer Type.
SinD = Sin(_D2R(degrees))
End Function
' use angles in degrees units instead of radians (converted inside sub)
Function DAtan2 (x1, y1, x2, y2) ' The angle in degrees a 2nd point (x2, y2) makes to a first point (x1, y1)
' Note this function uses whatever the default type is, better not be some Integer Type.
' Delta means change between 1 measure and another for example x2 - x1
Dim deltaX, deltaY, rtn
deltaX = x2 - x1
deltaY = y2 - y1
' To find the angle point(x2, y2) makes to (x1, y1) in Degrees
' Take DegreeAngle = DAtan2(y2 - y1, x2 - x1)
rtn = _R2D(_Atan2(deltaY, deltaX))
If rtn < 0 Then DAtan2 = rtn + 360 Else DAtan2 = rtn
End Function
' use angles in degrees units instead of radians (converted inside sub)
Sub ArrowTo (BaseX As Long, BaseY As Long, dAngle As Double, lngth As Long, colr As _Unsigned Long)
Dim As Long x1, y1, x2, y2, x3, y3
Dim As Double rAngle
rAngle = _D2R(dAngle)
x1 = BaseX + lngth * Cos(rAngle)
y1 = BaseY + lngth * Sin(rAngle)
x2 = BaseX + .8 * lngth * Cos(rAngle - _Pi(.05))
y2 = BaseY + .8 * lngth * Sin(rAngle - _Pi(.05))
x3 = BaseX + .8 * lngth * Cos(rAngle + _Pi(.05))
y3 = BaseY + .8 * lngth * Sin(rAngle + _Pi(.05))
Line (BaseX, BaseY)-(x1, y1), colr
Line (x1, y1)-(x2, y2), colr
Line (x1, y1)-(x3, y3), colr
End Sub
' use angles in degrees units instead of radians (converted inside sub)
Sub drawArc (xc, yc, radius, dStart, dMeasure, colr As _Unsigned Long)
' xc, yc Center for arc circle
' rStart is the Radian Start Angle, use _D2R for conversion from Degrees to Radians
' rMeasure is the measure of Arc in Radain units, use _D2R for conversion from Degrees to Radians
' Arc will start at rStart and go clockwise around for rMeasure Radians
Dim rStart, rMeasure, rEnd, stepper, a, x, y
rStart = _D2R(dStart)
rMeasure = _D2R(dMeasure)
rEnd = rStart + rMeasure
stepper = 1 / radius ' the bigger the radius the smaller the steps
For a = rStart To rEnd Step stepper
x = xc + radius * Cos(a)
y = yc + radius * Sin(a)
If a > rStart Then Line -(x, y), colr Else PSet (x, y), colr
Next
End Sub
'' BEST saves dest and optimized with Static a& and alpha colors work better
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub TriFill (x1, y1, x2, y2, x3, y3, K As _Unsigned Long) ' 2022-10-13 changed name
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End SubCorrection (2022-10-16): Though not used here, I forgot to change the color of the first point drawn in Sub for drawing regular polygons, fixed now.
b = b + ...