' BAM Port by Charlie Veniot
' of the QB64PE program found at https://qb64phoenix.com/forum/showthread.php?tid=1920
' ' This program exported from BASIC Anywhere Machine (Version [5.2.3].[2023.08.08.01.01]) on 2023.08.19 at 19:26 (Coordinated Universal Time)

'Fhex
'by James D. Jarvis August 19,2023
'draw a filled hex
'demo code

Screen _NewImage(500, 500, 27)
rr = 200
declare Sub ang_line (sx, sy, lnth, ang, klr As Long)
declare Sub fcirc (CX As Long, CY As Long, R, klr As Long)
declare Sub fhex (cx As Long, cy As Long, r, klr As Long)

For d = 1 To 10
    fcirc (250, 250, rr, _RGB32(200, 200, 0) )
    fhex (250, 250, rr, _RGB32(200, 100, 100) )
    rr = rr * .86
Next d
For a = 60 To 360 Step 60
    ang_line (250, 250, 200, a, _RGB32(250, 0, 0) )
Next a
 
hx = 60: hy = 60: hl = 12
fhex ( hx, hy, hl, _RGB32(100, 100, 100) )
For ha = 30 To 390 Step 60
    hx = 60 + (hl * 1.9) * Cos(0.01745329 * ha)
    hy = 60 + (hl * 1.9) * Sin(0.01745329 * ha)
    fhex ( hx, hy, hl, _RGB32(ha / 2, ha / 2, ha / 20) )
Next ha
 
Sub fhex (cx As Long, cy As Long, r, klr As Long)
    'draw a hex to radius r filled with color klr centeted on cx,cy
    rcheck = ((r * .867) * (r * .867))
    For dY = -r To r
        If dY * dY < rcheck Then
            dx = r - Abs(dY / _Pi * 1.81)
            Line (cx - dx, dY + cy)-(cx + dx, dY + cy), klr, BF
        End If
    Next dY
End Sub
 
 
'ang_line and fcirc included for demo not needed for fhex itself
Sub ang_line (sx, sy, lnth, ang, klr As Long)
    'draw a line lnth units long from sx,sy at anlge ang measures in degrees, 0 deg is out along X axis
    nx = sx + lnth * Cos(0.01745329 * ang)
    ny = sy + lnth * Sin(0.01745329 * ang)
    Line (sx, sy)-(nx, ny), klr
 
End Sub
Sub fcirc (CX As Long, CY As Long, R, klr As Long)
    'draw a filled circle with the quickest filled circle routine in qb64, not my development
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0
    If subRadius = 0 Then PSet (CX, CY): Exit Sub
    Line (CX - X, CY)-(CX + X, CY), klr, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), klr, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), klr, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), klr, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), klr, BF
    Wend
End Sub