Poly-dungeon

[James D Jarvis]

I'm a horrible nerd; I'm into tabletop RPGS and Basic programming. I'm always working on utility programs for my gaming needs. Here's an early in progress version of a dungeon generator. It's got a few rough edges that haven't been filed-off just yet.

Code: (Select All)

'polygon dungeon
'By James D. Jarvis, Sept 2022
Screen _NewImage(800, 600, 32)
Cls
Randomize Timer
Dim Shared shape(8)
shape(1) = 120: shape(2) = 90: shape(3) = 72: shape(4) = 60: shape(5) = 45: shape(6) = 40: shape(7) = 30: shape(8) = 6
Dim p As _Unsigned Long
Dim Shared Kwall As _Unsigned Long
Dim Shared Kfill As _Unsigned Long
Dim Shared kfloor As _Unsigned Long
Type roomtype
    x As Integer
    y As Integer
    r As Integer
    turn As Integer
    shape As Integer
End Type
Kwall = _RGB32(240, 240, 240)
Kfill = _RGB32(160, 160, 160)
kfloor = _RGB32(250, 230, 210)
Dim Shared room(60) As roomtype

numrooms = 20 + Int(Rnd * 30)


Line (0, 0)-(800, 600), _RGB32(160, 160, 160), BF
For x = 1 To numrooms

    Do
        flag$ = "good"
        room(x).x = Int(Rnd * 700) + 50
        room(x).y = Int(Rnd * 500) + 50
        room(x).r = 12 + Int(Rnd * 30)
        room(x).turn = Int(Rnd * 90)
        room(x).shape = Int(1 + Rnd * 8)

        If room(x).x + room(x).r > 798 Then flag$ = "bad"
        If room(x).y + room(x).r > 598 Then flag$ = "bad"
        If Point(room(x).x, room(x).y) <> Kfill Then flag$ = "bad"
    Loop Until flag$ = "good"
    rotpoly room(x).x, room(x).y, room(x).r, shape(room(x).shape), room(x).turn, Kwall
    Paint (room(x).x, room(x).y), kfloor, Kwall

Next x

For x = 1 To numrooms - 1
    '   Line Input ; A$
    Select Case Int(1 + Rnd * 4)
        Case 1 'straight line connect
            fatline room(x).x, room(x).y, room(x + 1).x, room(x + 1).y, 2, kfloor
        Case 2, 3, 4 'right angle jank
            targetx = room(x + 1).x
            targety = room(x + 1).y
            sx = room(x).x: sy = room(x).y
            Do
                s = Int(1 + Rnd * 6)
                On s GOTO skip1, skip2, skip3

                skip0:
                If targetx < startx Then
                    tx = tx - Int(3 + Rnd * 8)
                    If tx < targetx Then tx = targetx
                End If
                skip1:
                If targetx > startx Then
                    tx = tx + Int(3 + Rnd * 8)
                    If tx > targetx Then tx = targetx
                End If
                skip2:

                If targety < starty Then
                    ty = ty - Int(3 + Rnd * 8)
                    If ty < targety Then ty = targety
                End If
                skip3:
                If targety > starty Then
                    ty = ty + Int(3 + Rnd * 8)
                    If ty > targety Then ty = targety
                End If
                fatline sx, sy, tx, ty, 2, kfloor
                sx = tx: sy = ty
                If Abs(target - tx) < 12 And Abs(target - tx) < 12 Then
                    tx = targetx: ty = targety
                    fatline sx, sy, tx, ty, 2, kfloor
                End If
            Loop Until tx = targetx And ty = targety

    End Select
Next x


For x = 1 To numrooms
    Color _RGB32(40, 0, 0), kfloor
    pt$ = _Trim$(Str$(x))
    pw = _PrintWidth(pt$)
    _PrintString (room(x).x - pt / 2, room(x).y - 8), pt$
Next x


Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)
    rsqrd = r * r
    y = -r
    While y <= r
        x = Sqr(rsqrd - y * y)
        Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF
        y = y + 1
    Wend
End Sub

Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
    x = rr * Sin(0.01745329 * turn)
    y = rr * Cos(0.01745329 * turn)
    Line (cx + x, cy + y)-(cx + x, cy + y), klr
    For deg = turn To turn + 360 Step shapedeg
        x2 = rr * Sin(0.01745329 * deg)
        y2 = rr * Cos(0.01745329 * deg)
        Line -(cx + x2, cy + y2), klr
    Next
End Sub



Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
    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
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 = (2 * dy) - dx
    d = (dy + dy) - dx
    y = y0
    For x = x0 To x1
        circleBF x, y, r, klr

        If d > 0 Then
            y = y + yi
            ' D = D + (2 * (dy - dx))
            d = d + ((dy - dx) + (dy - dx))
        Else
            ' D = D + 2 * dy
            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 = (2 * dx) - dy
    D = (dx + dx) - dy
    x = x0
    For y = y0 To y1
        circleBF x, y, r, klr

        If D > 0 Then
            x = x + xi
            ' D = D + (2 * (dx - dy))
            D = D + ((dx - dy) + (dx - dy))
        Else
            ' D = D + 2 * dx
            D = D + dx + dx
        End If
    Next y
End Sub

[bplus]

Thumbs up!

@James D Jarvis you might like this:
https://qb64forum.alephc.xyz/index.php?topic=3020.0

[James D Jarvis]

Thumbs up!

@James D Jarvis you might like this:
https://qb64forum.alephc.xyz/index.php?topic=3020.0

Thanks I always enjoy seeing other folks efforts on these sort of things.   Here's a screen shot of another one I got cooking that isn't share-worthy just yet.