'Fhex

'by James D. Jarvis August 19,2023

'draw a filled hex

'demo code

Screen _NewImage(500, 500, 32)

rr = 200

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 _Unsigned 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 _Unsigned 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 _Unsigned 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

• Run the program
  
• View the source code
  

(08-19-2023, 07:29 PM)CharlieJV Wrote: I'm always looking for programs to test BAM in general and QB64PE compatibility.  Thanks!

• Run the program
  
• View the source code