'crop circles version 0.1

'by James D. Jarvis, July 2023

'this is modifed from a larger image generation program I am working on so if you read the code some of thsi is goign to be strange

'there are likely stubs and variables not actually used in the cropcircle generation that are used in the original, but it works for a goofy little demo

ymax = 800

xmax = 800

'$dynamic

Screen _NewImage(xmax, ymax, 32)

Dim flrklr As _Unsigned Long

tilescale = 4

Type roomtype

    fill As Integer

    rx As Integer

    ry As Integer

    nw As Integer

    sw As Integer

    ew As Integer

    ww As Integer

    cnx As Integer

End Type

Dim Shared rm(0) As roomtype

Dim Shared floorklr As _Unsigned Long

Dim Shared wallklr As _Unsigned Long

Dim Shared emptyklr As _Unsigned Long

floorklr = _RGB32(220, 220, 0)

wallklr = _RGB32(50, 50, 50)

emptyklr = _RGB32(80, 200, 15)



Type band_type

    rad As Integer

    s As Integer

    e As Integer

    spoke As Integer

    thk As Single

End Type



Dim Shared band(0) As band_type

Dim Shared oring(0) As band_type

Dim Shared tessfix

Dim Shared roomfix, excludeturrets

Dim Shared fillcellchance, defaulthallwidth

Dim Shared bumpchance, antennachance

bumpchance = 20

antennachance = 60

floorgrid = 0

forcegeneration = 0

linkgeneration = 0

tessfix = 0

roomfix = 0

fillcellchance = 50

firstpass = 1

Cls

Do



    Cls , emptyklr



    'grassfill 0, 0, xmax, ymax



    cb = 2 + Int(Rnd * 8)

    ReDim band(cb) As band_type

    mr = Int(_Height / 4 + Rnd * _Height / 6)

    mrp = Int(mr / cb)

    r = 0

    For c = 1 To cb

        r = r + Int((mrp / 3) * Int(2 + Rnd * 2))

        band(c).rad = r

        If c = 1 Then

            band(c).s = Int(Rnd * 360)

            band(c).e = band(c).s + band(c).s + (10 * Int(Rnd * 36))

        Else

            band(c).s = band(c - 1).spoke - (Int(1 + Rnd * 60) * 3)

            band(c).e = band(c - 1).spoke + (Int(1 + Rnd * 60) * 3)

            ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * band(c - 1).spoke)

            ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * band(c - 1).spoke)

            ppx2 = cx + band(c).rad * Cos(0.01745329 * band(c - 1).spoke)

            ppy2 = cy + band(c).rad * Sin(0.01745329 * band(c - 1).spoke)

            fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr

        End If

        bsiz = band(c).e - band(c).s

        band(c).spoke = Int(band(c).s + Rnd * bsiz)



        If Rnd * 100 < bumpchance Then

            rs = band(c).s: re = band(c).e

            bsiz = re - rs

            nb = Int((1 + Rnd * 12) / Int(1 + Rnd * 4))

            If nb < 1 Then nb = 1

            For bb = 1 To nb

                srangle = Int(rs + Rnd * bsiz)

                erangle = srangle + (Int(2 + Rnd * 11) * 3)

                bd = Int(1 + Rnd * 5) * tilescale

                If Rnd * 200 < bumpchance Then bd = bd * 2



                For d = 0.5 To bd Step 0.5

                    fatarc cx, cy, 2, band(c).rad + d, srangle, erangle, floorklr

                Next d

            Next bb

        End If



    Next



    roomcount = 0

    lastcount = 0

    For b = 1 To cb

        rs = band(b).s: re = band(b).e

        bsiz = re - rs

        mrbc = (bsiz * 0.01745329 * band(b).rad) / ((tilescale * tilescale) * 4)

        roomcount = roomcount + Int(1 + Rnd * mrbc)

        ReDim _Preserve rm(roomcount) As roomtype

        For r = lastcount + 1 To roomcount

            rangle = Int(rs + Rnd * bsiz)

            'rangle = Int(Rnd * 90) * 4

            rm(r).rx = cx + band(b).rad * Cos(0.01745329 * rangle)

            rm(r).ry = cy + band(b).rad * Sin(0.01745329 * rangle)

            rm(r).nw = 3 + Int(Rnd * 6) * tilescale

            rm(r).sw = 3 + Int(Rnd * 6) * tilescale

            rm(r).ew = 3 + Int(Rnd * 6) * tilescale

            rm(r).ww = 3 + Int(Rnd * 6) * tilescale



            If (Rnd * 101) < fillcellchance Then

                rm(r).fill = Int(1 + Rnd * 10) * (tilescale / 2)

            Else

                rm(r).fill = 0

            End If

            If rm(r).fill = 0 Then

                ' Circle (rm(r).rx, rm(r).ry), rm(r).nw, floorklr

                fatarc rm(r).rx, rm(r).ry, 2, rm(r).nw, 0, 359, floorklr

            Else

                fcirc rm(r).rx, rm(r).ry, rm(r).fill, floorklr

            End If

        Next r

        lastcount = roomcount

    Next b



    For c = 1 To cb

        cx = _Width \ 2: cy = _Height \ 2



        fatarc cx, cy, 2, band(c).rad, band(c).s, band(c).e, floorklr





        If c > 1 Then

            k = Int(c / 2 + Rnd * (c * 1.2))



            For n = 1 To k

                rs = band(c - 1).s: re = band(c - 1).e

                bsiz = re - rs

                ang = Int(rs + Rnd * bsiz)

                ppx1 = cx + band(c - 1).rad * Cos(0.01745329 * ang)

                ppy1 = cy + band(c - 1).rad * Sin(0.01745329 * ang)

                ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)

                ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)

                fatline ppx1, ppy1, ppx2, ppy2, 2, floorklr

            Next

        End If



        If c = cb Then

            rs = band(c).s: re = band(c).e

            bsiz = re - rs

            ang = -1 * Int(rs + Rnd * bsiz)

            fx = 0

            fy = 0

            ppx2 = cx + band(c).rad * Cos(0.01745329 * ang)

            ppy2 = cy + band(c).rad * Sin(0.01745329 * ang)

            cc = cb

            Do

                cc = cc - 1

                xc = cx + band(cc).rad * Cos(0.01745329 * ang)

                yc = cy + band(cc).rad * Sin(0.01745329 * ang)

                If Point(xc, yc) <> emptyklr Then

                    fx = xc

                    fy = yc

                End If



            Loop Until fx <> 0 And fy <> 0 Or cc = 1

            If fx = 0 Then

                fx = cx

                fy = cy

                rs = band(1).s: re = band(1).e

                bsiz = re - rs

                ang = Int(rs + Rnd * bsiz)

                tx = cx + band(1).rad * Cos(0.01745329 * ang)

                ty = cy + band(1).rad * Sin(0.01745329 * ang)



                fatline cx, cy, tx, ty, 2, floorklr

            End If

            fatline fx, fy, ppx2, ppy2, 2, floorklr



        End If

    Next c

    For a = 1 To 5

        If Rnd * 100 < antennachance Then

            tb = Int(1 + Rnd * cb)

            rs = band(tb).s: re = band(tb).e

            bsiz = re - rs

            bangle = Int(rs + Rnd * bsiz)

            DB = mr + 20

            dx = cx + DB * Cos(0.01745329 * bangle)

            dy = cy + DB * Sin(0.01745329 * bangle)

            ppx2 = cx + band(tb).rad * Cos(0.01745329 * bangle)

            ppy2 = cy + band(tb).rad * Sin(0.01745329 * bangle)

            fatline dx, dy, ppx2, ppy2, 2, floorklr

            Select Case Int(1 + Rnd * 16)

                ' Select Case 14

                Case 1, 2

                    fcirc dx, dy, Int(5 + Rnd * 10), floorklr

                Case 3, 4, 5, 6, 7, 8

                    fangs = bangle - Int(2 + Rnd * 10)

                    fange = bangle + Int(2 + Rnd * 10)

                    bd = Int(1 + Rnd * 5) * tilescale



                    For d = 0.5 To bd Step 0.5

                        fatarc cx, cy, 2, DB + d, fangs, fange, floorklr

                    Next d

                Case 10, 11, 12

                    fanga = Int(2 + Rnd * 10) * 10



                    bd = Int(2 + Rnd * 10) * tilescale



                    For da = bangle - fanga To bangle + fanga

                        DB = mr + 20

                        nx = dx + bd * Cos(0.01745329 * da)

                        ny = dy + bd * Sin(0.01745329 * da)

                        fatline dx, dy, nx, ny, 2, floorklr

                    Next da

                Case 13, 14, 15, 16

                    orrc = Int(2 + Rnd * 3)

                    ReDim oring(orrc) As band_type

                    r2 = 0

                    For o = 1 To orrc

                        r2 = r2 + Int(2 + Rnd * 2) * tilescale

                        oring(o).rad = r2

                        oring(o).s = 0

                        oring(o).e = 359

                        oring(o).thk = 0.75

                        fatarc dx, dy, 2, oring(o).rad, 0, 359, floorklr

                    Next o





            End Select



        End If

    Next

    Do

        redraw = 0

        Do

            _Limit 60

            kk$ = InKey$

            If firstpass = 1 Then

                firstpass = 0

                redraw = 1

                kk$ = "go"

            End If

        Loop Until kk$ <> ""





        Select Case kk$

            Case "c" 'copy to clipboard.... this is only supported in windows

                _ClipboardImage = dngi&



            Case "m", "M"

                rrr$ = Str$(tilescale)

                getroun$ = _InputBox$("Shape Magnitude", "Enter new magnitude (4) is standard.", rrr$)

                tilescale = Int(Val(getroun$))

                If tilescale < 1 Then tilescale = 1

            Case Else

                redraw = 1

        End Select

    Loop Until redraw = 1



Loop Until kk$ = Chr$(27)





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





Sub fatarc (cx, cy, thk, r, sang, eang, klr As _Unsigned Long)



    For rangle = sang To eang Step 0.5

        ax = cx + r * Cos(0.01745329 * rangle)

        ay = cy + r * Sin(0.01745329 * rangle)

        fcirc ax, ay, thk, klr

    Next rangle

End Sub



Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)

    'draw a line with dots with a radial thickness of r    from x0,y0 to x1,y1 in color klr

    If r > 0.5 Then

        If Abs(y1 - y0) < Abs(x1 - x0) Then

            If x0 > x1 Then



                lineLow x1, y1, x0, y0, r, klr

            Else



                lineLow x0, y0, x1, y1, r, klr

            End If

        Else

            If y0 > y1 Then

                lineHigh x1, y1, x0, y0, r, klr

            Else

                lineHigh x0, y0, x1, y1, r, klr

            End If

        End If

    Else

        Line (x0, y0)-(x1, y1), klr 'line with r of <= 0.5 don't render properly so we force them to be 1 pixel wide on screen

    End If

End Sub

Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0

    dy = y1 - y0

    yi = 1

    If dy < 0 Then

        yi = -1

        dy = -dy

    End If

    d = (dy + dy) - dx

    y = y0

    For x = x0 To x1

        fcirc x, y, r, klr

        If d > 0 Then

            y = y + yi

            d = d + ((dy - dx) + (dy - dx))

        Else

            d = d + dy + dy

        End If

    Next x

End Sub

Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)

    dx = x1 - x0

    dy = y1 - y0

    xi = 1

    If dx < 0 Then

        xi = -1

        dx = -dx

    End If

    D = (dx + dx) - dy

    x = x0

    For y = y0 To y1

        fcirc x, y, r, klr

        If D > 0 Then

            x = x + xi

            D = D + ((dx - dy) + (dx - dy))

        Else

            D = D + dx + dx

        End If

    Next y

End Sub



Function inscreen (xx, yy)

    'check if point is inside the boreders of the current screen

    ii = 1

    If xx < 1 Or xx > _Width - 1 Then ii = 0

    If yy < 1 Or yy > _Height - 1 Then ii = 0

    inscreen = ii

End Function

Sub paintifborder (xx, yy, klr As _Unsigned Long)

    If xx = 0 Or xx = _Width Or yy = 0 Or yy = _Height Then

        PSet (xx, yy), klr

    End If

End Sub

Sub grassfill (x1, y1, x2, y2)

    Cls

    Line (x1, y1)-(x2, y2), _RGB32(40, 240, 40), BF

    For yy = y1 To y2

        For xx = x1 To x2 Step 2

            bx = Int(Rnd * 2)

            Line (xx + bx, yy)-(xx + bx, yy - Int(Rnd * 3)), _RGB32(55 + Int(Rnd * 10), 225 + Int(Rnd * 10), 15 + Int(Rnd * 10))





        Next

    Next





End Sub

(07-23-2023, 12:59 PM)James D Jarvis Wrote: edit: darn aliens