Poly-dungeon - Printable Version

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