Keskustelu: Koodit: QB: Satunnainen luolasto

DEFINT A-Z
DECLARE SUB DeleteHall (X%, y%)
DECLARE SUB CalcEndPoint (X%, y%, lgh%, D%, ox%, oy%)
DECLARE SUB PutDoor (X%, y%)
DECLARE SUB DigHall (x1%, y1%, L%, D%)
DECLARE SUB DigRoom (x1%, y1%, x2%, y2%)
DECLARE SUB Generate (NumOfRooms, ix, iy, ax, ay, todenn)
DECLARE SUB PutDoors (todenn)
DECLARE FUNCTION Max% (a%, b%)
DECLARE FUNCTION Min% (a%, b%)
DECLARE FUNCTION Rand% (lowest%, Highest%)
DECLARE FUNCTION CheckHall% (x1%, y1%, L%, D%)
DECLARE FUNCTION CheckRoom% (x1%, y1%, x2%, y2%)
DECLARE FUNCTION PutRoom% (X%, y%, D%, ix%, iy%, ax%, ay%)
DECLARE FUNCTION CheckMax% (X%, y%, RxMin%, RyMin%, D%, sizeX1, sizeY1, sizeX2, sizeY2)
DECLARE FUNCTION RotateWall% (a%)
DECLARE FUNCTION Valille% (Alku%, Loppu%, pakollinen%, pituus%)

CONST maxx = 80         ' Kentän koko
CONST maxy = 47         '
CONST HuoneetLKM = 20   ' Piirrettävien huoneiden lukumäärä

CONST HuoneetMinX = 3   ' Huoneiden minimi/maksimi koot.
CONST HuoneetMinY = 3   '
CONST HuoneetMaxX = 7   ' HUOM! Huoneista tulee ruudun verran
CONST HuoneetMaxY = 7   ' määriteltyä isommat... en ole jaksanut korjata :)

CONST OviTodenn = 70   ' % todennäköisyys, jolla piirretään
                        ' huoneen suuaukolle ovi.

DIM SHARED Dungeon(maxx, maxy) AS INTEGER
DIM SHARED RoomHolder(1 TO HuoneetLKM, 3) ' Piirrettyjen huoneiden kordinaatit:
                                          ' RoomHolder( , 0) = x1
                                          ' RoomHolder( , 1) = y1
                                          ' RoomHolder( , 2) = x2
                                          ' RoomHolder( , 3) = y2

DIM SHARED maara        ' Tähän arvoon tallentuu ONNISTUNEESTI
                        ' piirrettyjen huoneiden lukumäärä.
CONST Wall = 1
CONST Floor = 2
CONST door = 3

CLS
RANDOMIZE TIMER
aika! = TIMER
WIDTH 80, 50
' *** Luodaan luola ***
Generate HuoneetLKM, HuoneetMinX, HuoneetMinY, HuoneetMaxX, HuoneetMaxY, OviTodenn

PRINT "Käytetty aika:"; TIMER - aika!
PRINT "Piirretyt huoneet:"; maara
FOR y = 1 TO maxy
        FOR X = 1 TO maxx
        IF Dungeon(X, y) = Wall THEN PRINT "Û";
        IF Dungeon(X, y) = Floor THEN PRINT ".";
        IF Dungeon(X, y) = door THEN PRINT "+";
        IF Dungeon(X, y) = 0 THEN PRINT " ";
        NEXT X
NEXT y

SUB CalcEndPoint (X, y, lgh, D, ox, oy) ' Laskee käytävän pään kordinaatit
SELECT CASE (D)
        CASE 1
                ox = X
                oy = y + lgh
        CASE -1
                ox = X
                oy = y - lgh
        CASE 2
                ox = X + lgh
                oy = y
        CASE -2
                ox = X - lgh
                oy = y
END SELECT
END SUB

FUNCTION CheckHall (x1, y1, L, D)       ' Tarkistaa onko piirrettävälle käytävälli
' D=1 Etelään                           ' riittävästi tilaa
' D=-1 Pohjoiseen
' D=2 Itään
' D=-2 Länteen
IF x1 <= 1 OR x1 > maxx THEN CheckHall = 0: EXIT FUNCTION
IF y1 <= 1 OR y1 > maxy THEN CheckHall = 0: EXIT FUNCTION

IF Dungeon(x1, y1) <> Wall THEN CheckHall = 0: EXIT FUNCTION
IF x1 - 1 < 1 OR x1 > maxx - 1 THEN CheckHall = 0: EXIT FUNCTION
IF y1 - 1 < 1 OR y1 > maxy - 1 THEN CheckHall = 0: EXIT FUNCTION

IF ABS(D) = 1 THEN
        IF y1 + L * SGN(D) > maxy - 1 OR y1 + L * SGN(D) <= 1 THEN CheckHall = 0: EXIT FUNCTION 'Tarkastetaan, meneekö käytävä piirrettäess yli kartan reunojen.
        FOR y = y1 TO y1 + L * SGN(D) STEP SGN(D)
         FOR vaaka = -1 TO 1
         Tile = Dungeon(x1 + vaaka, y)
         IF Tile <> Wall THEN CheckHall = 0: EXIT FUNCTION
         NEXT vaaka
        NEXT y
        IF Dungeon(x1, y) <> Floor THEN IF Dungeon(x1 - 1, y) <> Wall OR Dungeon(x1 + 1, y) <> Wall THEN CheckHall = 0: EXIT FUNCTION
END IF

IF ABS(D) = 2 THEN
        IF x1 + L * SGN(D) > maxx - 1 OR x1 + L * SGN(D) <= 1 THEN CheckHall = 0: EXIT FUNCTION 'Tarkastetaan, meneekö käytävä piirrettäess yli kartan reunojen.
        FOR X = x1 TO x1 + L * SGN(D) STEP SGN(D)
         FOR vaaka = -1 TO 1
         Tile = Dungeon(X, y1 + vaaka)
         IF Tile <> Wall THEN CheckHall = 0: EXIT FUNCTION
         NEXT vaaka
        NEXT X
        IF Dungeon(X, y1) <> Floor THEN IF Dungeon(X, y1 - 1) <> Wall OR Dungeon(X, y1 + 1) <> Wall THEN CheckHall = 0: EXIT FUNCTION
END IF

CheckHall = 1
END FUNCTION

                                ' Tutkii maksimikoon huoneelle.
FUNCTION CheckMax (X, y, RxMin, RyMin, D, sizeX1, sizeY1, sizeX2, sizeY2)
' D=1 Etelään
' D=-1 Pohjoiseen
' D=2 Itään
' D=-2 Länteen
SELECT CASE (D)
        CASE 1                '
                sx = X
                sy = y - 2
                x1 = -1       '   #####
                y1 = -1       '   #   #
                x2 = 1        '   ###+#
                y2 = 0        '
        CASE -1               '
                sx = X        '
                sy = y + 2    '   ###+#
                x1 = -1       '   #   #
                y1 = 0        '   #   #
                x2 = 1        '   #####
                y2 = 1        '
        CASE -2               '
                sx = X + 2    '
                sy = y        '
                x1 = 0        '   #####
                y1 = -1       '   +   #
                x2 = 1        '   #####
                y2 = 1        '
        CASE 2                '
                sx = X - 2    '
                sy = y        '   #####
                x1 = -1       '   #   #
                y1 = -1       '   #   +
                x2 = 0        '   #####
                y2 = 1        '
END SELECT
noMoreX1 = 0
noMoreY1 = 0
noMoreX2 = 0
noMoreY2 = 0
sizeX1 = sx
sizeX2 = sx
sizeY1 = sy
sizeY2 = sy

DO
        IF CheckRoom(sizeX1 + x1, sizeY1 + y1, sizeX2 + x2, sizeY2 + y2) = 0 THEN
                IF noMoreX1 = 0 THEN IF CheckRoom(sizeX1 + x1, sizeY1, sizeX2, sizeY2) = 0 THEN noMoreX1 = 1
                IF noMoreY1 = 0 THEN IF CheckRoom(sizeX1, sizeY1 + y1, sizeX2, sizeY2) = 0 THEN noMoreY1 = 1
                IF noMoreX2 = 0 THEN IF CheckRoom(sizeX1, sizeY1, sizeX2 + x2, sizeY2) = 0 THEN noMoreX2 = 1
                IF noMoreY2 = 0 THEN IF CheckRoom(sizeX1, sizeY1, sizeX2, sizeY2 + y2) = 0 THEN noMoreY2 = 1
        END IF
        IF noMoreX1 + noMoreX2 + noMoreY1 + noMoreY2 >= 3 THEN EXIT DO
        IF noMoreX1 = 0 THEN sizeX1 = sizeX1 + x1
        IF noMoreY1 = 0 THEN sizeY1 = sizeY1 + y1
        IF noMoreX2 = 0 THEN sizeX2 = sizeX2 + x2
        IF noMoreY2 = 0 THEN sizeY2 = sizeY2 + y2

LOOP
IF sizeX2 - sizeX1 >= RxMin AND sizeY2 - sizeY1 >= RyMin THEN CheckMax = 1 ELSE CheckMax = 0
'PRINT (sizeX2 - sizeX1 >= RxMin)
'DigRoom sizeX1, sizeY1, sizeX2, sizeY2
END FUNCTION

FUNCTION CheckRoom (x1, y1, x2, y2)
IF x1 - 1 < 1 OR x2 > maxx - 1 THEN CheckRoom = 0: EXIT FUNCTION
IF y1 - 1 < 1 OR y2 > maxy - 1 THEN CheckRoom = 0: EXIT FUNCTION
FOR X = x1 - 1 TO x2 + 1
        FOR y = y1 - 1 TO y2 + 1
        IF Dungeon(X, y) <> Wall THEN CheckRoom = 0: EXIT FUNCTION
        NEXT y
NEXT X
CheckRoom = 1
END FUNCTION

SUB DeleteHall (X, y)
mx = X
my = y
nx = X
ny = y
DO
        FloorCount = 0
        IF Dungeon(mx - 1, my) = Floor THEN FloorCount = FloorCount + 1: nx = mx - 1
        IF Dungeon(mx + 1, my) = Floor THEN FloorCount = FloorCount + 1: nx = mx + 1
        IF Dungeon(mx, my - 1) = Floor THEN FloorCount = FloorCount + 1: ny = my - 1
        IF Dungeon(mx, my + 1) = Floor THEN FloorCount = FloorCount + 1: ny = my + 1
        IF FloorCount = 0 THEN Dungeon(mx, my) = Wall: EXIT SUB
        IF FloorCount <> 1 THEN EXIT SUB
        Dungeon(mx, my) = Wall
        mx = nx
        my = ny
LOOP
END SUB

SUB DigHall (x1, y1, L, D)      ' Piirtää huoneen
IF ABS(D) = 1 THEN
        FOR y = y1 TO y1 + L * SGN(D) STEP SGN(D)
        Dungeon(x1, y) = Floor
        NEXT y
END IF
IF ABS(D) = 2 THEN
        FOR X = x1 TO x1 + L * SGN(D) STEP SGN(D)
        Dungeon(X, y1) = Floor
        NEXT X
END IF
END SUB

SUB DigRoom (x1, y1, x2, y2)
maara = maara + 1
RoomHolder(maara, 0) = x1
RoomHolder(maara, 1) = x2
RoomHolder(maara, 2) = y1
RoomHolder(maara, 3) = y2
FOR X = x1 TO x2
        FOR y = y1 TO y2
        Dungeon(X, y) = Floor
        NEXT y
NEXT X
END SUB

SUB Generate (NumOfRooms, ix, iy, ax, ay, todenn)
maara = 0
FOR X = 0 TO maxx
        FOR y = 0 TO maxy
        Dungeon(X, y) = Wall
        NEXT y
NEXT X

x1 = Rand(2, maxx - ax - 1)                     ' Eka huone.
y1 = Rand(2, maxy - ay - 1)                     ' -
DO                                              ' -
        x2 = Rand(x1 + ix, x1 + ax)             ' -
        y2 = Rand(y1 + iy, y1 + ay)             ' -
        IF CheckRoom(x1, y1, x2, y2) THEN EXIT DO
LOOP
DigRoom x1, y1, x2, y2                          ' Piirretään huone.

DO UNTIL maara >= NumOfRooms OR count > 200     ' Lopetetaan, kunnes huoneita on riittävästi tai
IF ok <> -1 THEN                                ' luovutetaan, kunnes 200. yritys on tullut täyteen.
        TheRoom = Rand(1, maara)                ' Arvotaan käsiteltävä huone.
        ELSE
        TheRoom = TheRoom + 1                   '
        IF TheRoom > maara THEN TheRoom = 1     '
END IF
TheWall = Rand(1, 2)                            ' Arvotaan seinä, johon yritetään piirtää käytävä.
IF Rand(0, 1) THEN TheWall = TheWall * -1       '

FOR suunnat = 1 TO 4
        SELECT CASE (TheWall)
                CASE 1                                         'Eteläinen seinä
                        StartY = RoomHolder(TheRoom, 3) + 1
                        StartX = Rand(RoomHolder(TheRoom, 0), RoomHolder(TheRoom, 1))
                        Mitta = RoomHolder(TheRoom, 1) - RoomHolder(TheRoom, 0)
                CASE -1                                        'Pohjoinen seinä
                        StartY = RoomHolder(TheRoom, 2) - 1
                        StartX = Rand(RoomHolder(TheRoom, 0), RoomHolder(TheRoom, 1))
                        Mitta = RoomHolder(TheRoom, 1) - RoomHolder(TheRoom, 0)
                CASE 2                                         'Itäinen seinä
                        StartY = Rand(RoomHolder(TheRoom, 2), RoomHolder(TheRoom, 3))
                        StartX = RoomHolder(TheRoom, 1) + 1
                        Mitta = RoomHolder(TheRoom, 3) - RoomHolder(TheRoom, 2)
                CASE -2                                        ' Läntinen seinä
                        StartY = Rand(RoomHolder(TheRoom, 2), RoomHolder(TheRoom, 3))
                        StartX = RoomHolder(TheRoom, 0) - 1
                        Mitta = RoomHolder(TheRoom, 3) - RoomHolder(TheRoom, 2)
        END SELECT

        FOR seina = 0 TO Mitta
                lgh = Rand(4, 10)
                IF Rand(1, 7) = 1 THEN lgh = lgh * Rand(1, 3)
                ok = 0
                DO UNTIL ok
                        SELECT CASE (CheckHall(StartX, StartY, lgh, TheWall))
                                CASE 1
                                        DigHall StartX, StartY, lgh, TheWall
                                        Dungeon(StartX, StartY) = Floor
                                        ok = 1
                                CASE 0
                                        IF lgh <= 2 THEN ok = -1 ELSE lgh = lgh - 1 ' Jos käytävän pituus on 2 tai pienempi luovutetaan. Muussa tapauksessa kokeillaan lyhentää käytävää.
                        END SELECT
                LOOP
                IF ok = 1 THEN EXIT FOR

                SELECT CASE (TheWall)
                        CASE 1
                                StartX = StartX + 1
                                IF StartX > RoomHolder(TheRoom, 1) THEN StartX = RoomHolder(TheRoom, 0)
                        CASE -1
                                StartX = StartX + 1
                                IF StartX > RoomHolder(TheRoom, 1) THEN StartX = RoomHolder(TheRoom, 0)
                        CASE 2
                                StartY = StartY + 1
                                IF StartY > RoomHolder(TheRoom, 3) THEN StartY = RoomHolder(TheRoom, 2)
                        CASE -2
                                StartY = StartY + 1
                                IF StartY > RoomHolder(TheRoom, 3) THEN StartY = RoomHolder(TheRoom, 2)
                END SELECT
        NEXT seina
        IF ok = 1 THEN EXIT FOR
        TheWall = RotateWall(TheWall)
NEXT suunnat
IF ok = 0 THEN ok = -1
CalcEndPoint StartX, StartY, lgh, TheWall, endX, endY
IF ok = 1 THEN
        IF PutRoom(endX, endY, TheWall, ix, iy, ax, ay) THEN
                ok = 0
                ELSE
                IF NOT PutRoom(endX, endY, StartX, ix, iy, ax, ay) THEN DeleteHall endX, endY
        END IF
END IF
count = count + 1
LOOP
PutDoors (todenn)
END SUB

FUNCTION Max (a, b)
IF a > b THEN Max = a ELSE Max = b
END FUNCTION

FUNCTION Min (a, b)
IF a < b THEN Min = a ELSE Min = b
END FUNCTION

SUB PutDoors (todenn)   ' Asettaa ovet sopiville paikoille.
FOR huoneet = 1 TO maara
        FOR yyt = 2 TO 3
                y = RoomHolder(huoneet, yyt)
                IF yyt = 2 THEN y = y - 1 ELSE y = y + 1
                FOR X = RoomHolder(huoneet, 0) TO RoomHolder(huoneet, 1)
                        IF Rand(1, 100) <= todenn THEN
                        IF Dungeon(X, y) = Floor AND Dungeon(X - 1, y) = Wall AND Dungeon(X + 1, y) = Wall THEN Dungeon(X, y) = door
                        END IF
                NEXT X
        NEXT yyt
        FOR xxt = 0 TO 1
                X = RoomHolder(huoneet, xxt)
                IF xxt = 0 THEN X = X - 1 ELSE X = X + 1
                FOR y = RoomHolder(huoneet, 2) TO RoomHolder(huoneet, 3)
                        IF Rand(1, 100) <= todenn THEN
                        IF Dungeon(X, y) = Floor AND Dungeon(X, y - 1) = Wall AND Dungeon(X, y + 1) = Wall THEN Dungeon(X, y) = door
                        END IF
                NEXT y
        NEXT xxt
NEXT huoneet
END SUB

FUNCTION PutRoom (X, y, D, ix, iy, ax, ay)

suunta = Rand(1, 2)
IF Rand(0, 1) THEN suunta = suunta * -1
FOR a = 1 TO 3
        IF suunta = D THEN suunta = RotateWall(suunta)
        IF CheckMax(X, y, ix, iy, suunta, x1, y1, x2, y2) THEN
                RoomX = Rand(ix, ax)
                IF RoomX > x2 - x1 THEN RoomX = x2 - x1
                RoomY = Rand(iy, ay)
                IF RoomY > y2 - y1 THEN RoomY = y2 - y1
                SELECT CASE (suunta)
                        CASE 1
                                ry1 = y2 - RoomY
                                ry2 = y2
                                rx1 = Valille(x1, x2, X, RoomX)
                                rx2 = rx1 + RoomX
                                DoorX = X
                                DoorY = y - 1
                        CASE -1
                                ry1 = y1
                                ry2 = y1 + RoomY
                                rx1 = Valille(x1, x2, X, RoomX)
                                rx2 = rx1 + RoomX
                                DoorX = X
                                DoorY = y + 1
                        CASE 2
                                ry1 = Valille(y1, y2, y, RoomY)
                                ry2 = ry1 + RoomY
                                rx1 = x2 - RoomX
                                rx2 = x2
                                DoorX = X - 1
                                DoorY = y
                        CASE -2
                                ry1 = Valille(y1, y2, y, RoomY)
                                ry2 = ry1 + RoomY
                                rx1 = x1
                                rx2 = x1 + RoomX
                                DoorX = X + 1
                                DoorY = y
                END SELECT
                PutRoom = 1
                DigRoom rx1, ry1, rx2, ry2
                Dungeon(DoorX, DoorY) = Floor
                EXIT FUNCTION
        END IF
        suunta = RotateWall(suunta)
NEXT a

END FUNCTION

FUNCTION Rand (a, b)    ' Arpoo luvun välillä a-b
IF a > b THEN
        High = a + 1
        Low = b
       ELSE
        High = b + 1
        Low = a
END IF
Dif = High - Low
Rand = INT(RND * Dif) + Low
END FUNCTION

FUNCTION RotateWall (a)
SELECT CASE (a)
        CASE 1
                RotateWall = 2
        CASE 2
                RotateWall = -2
        CASE -2
                RotateWall = -1
        CASE -1
                RotateWall = 1
END SELECT
END FUNCTION

FUNCTION Valille (Alku, Loppu, pakollinen, pituus)
oikea = pakollinen - pituus
IF oikea < Alku THEN oikea = Alku
vasen = pakollinen + pituus
yli = Loppu - vasen
IF yli < 0 THEN vasen = vasen + yli
AlkuVasen = vasen - pituus
Valille = Rand(oikea, AlkuVasen)
END FUNCTION