Keskustelu: Koodit: QB64: Tetris

'
' QB64 Tetris 0.5 made by Tero Ristolainen from Finland 2016.
'
' Works with QB64 and Windows only because of the font.
' Comments and some variables are finnish because of me being finnish.
' There are no music and joystick movement is limited.
'
_TITLE "Tetris 0.5"
RANDOMIZE TIMER
SCREEN _NEWIMAGE(480, 480, 256)
CLS

DIM Area$(23)
DIM Blox$(7, 4)
DIM Vari(7, 2)
DIM Yplus(7) ' turhahko muuttuja, asemoidaan seuraava palikka ikkunaan
DIM Xplus(7) ' sama
DIM Rivi(4)
DIM Bonus(4)
juuri$ = ENVIRON$("SYSTEMROOT"): tiedosto$ = juuri$ + "\Fonts\tahoma.ttf" ' Tahoma koska yhteensopivuus XP > 10
fontti& = _LOADFONT(tiedosto$, 22): _FONT fontti&
Bonus(1) = 40: Bonus(2) = 100: Bonus(3) = 300: Bonus(4) = 1200 ' rivien pisteytys kopioitu gameboy-versiosta
Area$(1) = STRING$(12, "#"): Area$(23) = STRING$(12, "#")

Blox$(1, 1) = "1111 1  1111 1  ": Vari(1, 1) = 7
Blox$(1, 2) = "     1       1  ": Vari(1, 2) = 15
Blox$(1, 3) = "     1       1  ": Xplus(1) = 10
Blox$(1, 4) = "     1       1  ": Yplus(1) = 10
Blox$(2, 1) = " 11  11  11  11 ": Vari(2, 1) = 2
Blox$(2, 2) = " 11  11  11  11 ": Vari(2, 2) = 10
Blox$(2, 3) = "                ": Xplus(2) = 10
Blox$(2, 4) = "                ": Yplus(2) = 0
Blox$(3, 1) = "111   1  1   11 ": Vari(3, 1) = 5
Blox$(3, 2) = "  1   1  111 1  ": Vari(3, 2) = 13
Blox$(3, 3) = "     11      1  ": Xplus(3) = 20
Blox$(3, 4) = "                ": Yplus(3) = 0
Blox$(4, 1) = " 111 11   1  1  ": Vari(4, 1) = 3
Blox$(4, 2) = " 1    1 111  1  ": Vari(4, 2) = 11
Blox$(4, 3) = "      1      11 ": Xplus(4) = 0
Blox$(4, 4) = "                ": Yplus(4) = 0
Blox$(5, 1) = " 11  1   11  1  ": Vari(5, 1) = 1
Blox$(5, 2) = "11   11 11   11 ": Vari(5, 2) = 9
Blox$(5, 3) = "      1       1 ": Xplus(5) = 20
Blox$(5, 4) = "                ": Yplus(5) = 0
Blox$(6, 1) = " 11   1  11   1 ": Vari(6, 1) = 4
Blox$(6, 2) = "  11 11   11 11 ": Vari(6, 2) = 12
Blox$(6, 3) = "     1       1  ": Xplus(6) = 0
Blox$(6, 4) = "                ": Yplus(6) = 0
Blox$(7, 1) = "111  1   1  1   ": Vari(7, 1) = 6
Blox$(7, 2) = " 1  11  111 11  ": Vari(7, 2) = 14
Blox$(7, 3) = "     1      1   ": Xplus(7) = 20
Blox$(7, 4) = "                ": Yplus(7) = 0

LINE (39, 19)-(280, 460), 8, B
LINE (299, 19)-(400, 100), 8, B

IF _FILEEXISTS("tetris.top") THEN ' luetaan highscore tiedostosta
    OPEN "tetris.top" FOR INPUT AS #1
    INPUT #1, highscore
    CLOSE #1
ELSE
    highscore = 0
    OPEN "tetris.top" FOR OUTPUT AS #1 ' jos eka pelikerta niin luodaan tiedosto
    PRINT #1, highscore
    CLOSE #1
END IF

Alku:

COLOR 15: GOSUB Pisteet

FOR Y = 1 TO 22: Area$(Y) = "#" + SPACE$(12) + "#": NEXT Y

COLOR 10: LOCATE 19, 300: PRINT "ENTER=PLAY"
DO
    g$ = INKEY$
    IF g$ = CHR$(13) OR STRIG(0) OR STRIG(4) THEN EXIT DO
    IF g$ = CHR$(27) THEN END
LOOP
COLOR 0: LOCATE 19, 300: PRINT "ENTER=PLAY": GOSUB Pisteet

score = 0: lines = 0: totallines = 0: level = 0: speed = .5: COLOR 15: GOSUB Pisteet
LINE (40, 20)-(279, 459), 0, BF
LINE (300, 20)-(399, 99), 0, BF
GOSUB Arvonta

DO

    X = 5: Y = 0: R = 0: s = speed: GOSUB Arvonta

    DO
        Komento = 1: GOSUB Palikka
        t = TIMER
        DO
            a$ = INKEY$
            SELECT CASE STICK(0)
                CASE 0 TO 80: IF pad$ <> "4" THEN pad$ = "4": padm = -1 ELSE padm = 0
                CASE 174 TO 254: IF pad$ <> "6" THEN pad$ = "6": padm = -1 ELSE padm = 0
                CASE ELSE: pad$ = ""
            END SELECT
            IF padm = -1 THEN a$ = pad$
            IF STRIG(0) THEN a$ = "8"
            IF STRIG(4) THEN a$ = "2"

            IF a$ <> "" THEN
                SELECT CASE a$
                    CASE CHR$(27): END
                    CASE CHR$(0) + "K", "4"
                        Komento = -1: GOSUB Tarkistus
                        IF stoppi = 0 THEN
                            Komento = -1: GOSUB Palikka
                            X = X - 1
                            Komento = 1: GOSUB Palikka
                        END IF
                    CASE CHR$(0) + "M", "6"
                        Komento = 1: GOSUB Tarkistus
                        IF stoppi = 0 THEN
                            Komento = -1: GOSUB Palikka
                            X = X + 1
                            Komento = 1: GOSUB Palikka
                        END IF
                    CASE CHR$(0) + "H", "8"
                        oldr = R
                        R = R + 1: IF R = 4 THEN R = 0
                        Komento = -2: GOSUB Tarkistus
                        IF stoppi = 1 THEN
                            R = oldr
                        ELSE
                            newr = R
                            R = oldr: Komento = -1: GOSUB Palikka
                            R = newr: Komento = 1: GOSUB Palikka
                        END IF
                    CASE CHR$(0) + "P", "2"
                        s = .05
                END SELECT
                stoppi = 0
            END IF
        LOOP UNTIL TIMER - t > s
        Komento = -2: GOSUB Tarkistus
        IF stoppi = 1 THEN
            GOSUB Piirra
            IF score >= highscore THEN
                highscore = score
                OPEN "tetris.top" FOR OUTPUT AS #1
                PRINT #1, highscore
                CLOSE #1
            END IF
            GOTO Alku
        END IF

        Komento = -1: GOSUB Palikka
        Komento = 0: GOSUB Tarkistus
        IF stoppi = 1 THEN
            Komento = 1: GOSUB Palikka
            Komento = 2: GOSUB Tarkistus
            GOSUB Poistot
            EXIT DO
        END IF
        Y = Y + 1

    LOOP
    GOSUB Pisteet

LOOP

Pisteet:
IF lines >= 20 THEN speed = speed - 0.05: level = level + 1: lines = lines - 20
LOCATE 7, 300: PRINT "HI-SCORE"
LOCATE 8, 300: PRINT highscore
LOCATE 10, 300: PRINT "SCORE"
LOCATE 11, 300: PRINT score
LOCATE 13, 300: PRINT "LINES"
LOCATE 14, 300: PRINT totallines
LOCATE 16, 300: PRINT "LEVEL"
LOCATE 17, 300: PRINT level
RETURN

Arvonta:
B = ob
ob = INT(RND * 7) + 1
LINE (300, 20)-(399, 99), 0, BF
FOR ox = 1 TO 4
    FOR oy = 1 TO 4
        IF MID$(Blox$(ob, oy), ox, 1) = "1" THEN
            LINE (280 + ox * 20 + Xplus(ob), 20 + oy * 20 + Yplus(ob))-(299 + ox * 20 + Xplus(ob), oy * 20 + 39 + Yplus(ob)), Vari(ob, 1), B
            LINE (281 + ox * 20 + Xplus(ob), oy * 20 + 21 + Yplus(ob))-(298 + ox * 20 + Xplus(ob), oy * 20 + 38 + Yplus(ob)), Vari(ob, 2), BF
        END IF
    NEXT
NEXT
RETURN

Poistot:
poistuu = 0
FOR py = 2 TO 22
    vali = 0
    FOR px = 2 TO 13
        IF MID$(Area$(py), px, 1) = " " THEN vali = 1
    NEXT px
    IF vali = 0 THEN
        poistuu = poistuu + 1: Rivi(poistuu) = py
        LINE (40, py * 20)-(279, py * 20 + 19), 15, BF
    END IF
NEXT py
IF poistuu > 0 THEN
    lines = lines + poistuu: totallines = totallines + poistuu
    score = score + Bonus(poistuu) * (level + 1)
    _DELAY .5
    FOR py = 2 TO 22
        vali = 0
        FOR px = 2 TO 13
            IF MID$(Area$(py), px, 1) = " " THEN vali = 1
        NEXT px
        IF vali = 0 THEN
            Area$(py) = "#" + SPACE$(12) + "#"
            LINE (40, py * 20)-(279, py * 20 + 19), 0, BF
        END IF
    NEXT py
    FOR z = 1 TO poistuu ' pudotetaan riveja
        FOR py = Rivi(z) TO 2 STEP -1
            Area$(py) = Area$(py - 1)
        NEXT py
    NEXT z
    GOSUB Piirra
END IF
RETURN

Piirra:
FOR py = 1 TO 22
    FOR px = 2 TO 13
        IF MID$(Area$(py), px, 1) <> " " THEN
            LINE (px * 20, py * 20)-(px * 20 + 19, py * 20 + 19), Vari(VAL(MID$(Area$(py), px, 1)), 1), B
            LINE (px * 20 + 1, py * 20 + 1)-(px * 20 + 18, py * 20 + 18), Vari(VAL(MID$(Area$(py), px, 1)), 2), BF
        ELSE
            IF stoppi = 1 THEN taustavari = 4 ELSE taustavari = 0
            LINE (px * 20, py * 20)-(px * 20 + 19, py * 20 + 19), taustavari, BF
        END IF
    NEXT px
NEXT py

RETURN

Tarkistus:
stoppi = 0
FOR tx = 1 TO 4
    FOR ty = 1 TO 4
        IF MID$(Blox$(B, ty), tx + R * 4, 1) = "1" THEN
            IF Komento = 0 AND MID$(Area$(Y + ty + 1), X + tx, 1) <> " " THEN stoppi = 1 ' tarkistetaan pohjakosketus
            IF Komento = -1 AND MID$(Area$(Y + ty), X + tx - 1, 1) <> " " THEN stoppi = 1 ' onko vasemmalla tilaa
            IF Komento = 1 AND MID$(Area$(Y + ty), X + tx + 1, 1) <> " " THEN stoppi = 1 ' onko oikealla tilaa
            IF Komento = -2 AND MID$(Area$(Y + ty), X + tx, 1) <> " " THEN stoppi = 1 ' mahtuuko pyorimaan
            IF Komento = 2 THEN MID$(Area$(Y + ty), X + tx, 1) = LTRIM$(STR$(B)) ' sijoitetaan palikka taulukkoon
        END IF
    NEXT
NEXT
RETURN

Palikka:
FOR zx = 1 TO 4
    FOR zy = 1 TO 4
        IF MID$(Blox$(B, zy), zx + R * 4, 1) = "1" THEN
            IF Komento = 1 THEN 'piirretaan palikka
                LINE (X * 20 + zx * 20, Y * 20 + zy * 20)-(X * 20 + zx * 20 + 19, Y * 20 + zy * 20 + 19), Vari(B, 1), B
                LINE (X * 20 + zx * 20 + 1, Y * 20 + zy * 20 + 1)-(X * 20 + zx * 20 + 18, Y * 20 + zy * 20 + 18), Vari(B, 2), BF
            ELSE 'poistetaan palikka
                LINE (X * 20 + zx * 20, Y * 20 + zy * 20)-(X * 20 + zx * 20 + 19, Y * 20 + zy * 20 + 19), 0, BF
            END IF
        END IF
    NEXT
NEXT
RETURN