Koodit: QB: Tetris

'QBasic-Tetris
'
'Parissa tunnissa koodattu alkeellinen tetris, jota voi käyttää
'oman pelin pohjana. Tekijä Antti Laaksonen

OPTION BASE 1 'taulukot alkavat 1:stä 0:n sijasta

CONST LEVEYS = 10 'kentän leveys
CONST KORKEUS = 18 'kentän korkeus
CONST PALIKAT = 6 'kuinka monta erilaista palikkaa on

TYPE arpa
  x AS INTEGER
  y AS INTEGER
END TYPE

TYPE lpalikka
  muoto AS INTEGER
  x AS INTEGER
  y AS INTEGER
  suunta AS INTEGER
END TYPE

DIM kentta(LEVEYS + 1, KORKEUS + 1)
DIM palikka(PALIKAT, 4, 4, 4) AS INTEGER
DIM npalikka AS lpalikka

'palikoiden lukeminen ja suuntien laskeminen
FOR i = 1 TO PALIKAT
  FOR j = 1 TO 4
    FOR k = 1 TO 4
      READ palikka(i, 1, j, k)
    NEXT
  NEXT
  FOR k = 2 TO 4
    FOR j = 1 TO 4
      palikka(i, k, 1, j) = palikka(i, k - 1, j, 4)
      palikka(i, k, 2, j) = palikka(i, k - 1, j, 3)
      palikka(i, k, 3, j) = palikka(i, k - 1, j, 2)
      palikka(i, k, 4, j) = palikka(i, k - 1, j, 1)
    NEXT
  NEXT
NEXT

SCREEN 13
LINE (0, 0)-(320, 200), 8, BF
COLOR 15

'kehysten piirtäminen
LOCATE 1, 1
PRINT "╔";
FOR i = 1 TO LEVEYS
  PRINT "═";
NEXT
PRINT "╗"
FOR i = 2 TO KORKEUS + 1
  PRINT "║";
  LOCATE i, 12
  PRINT "║"
NEXT
PRINT "╚";
FOR i = 1 TO LEVEYS
  PRINT "═";
NEXT
PRINT "╝"


uusipala = 1
RANDOMIZE TIMER
DO
  IF uusipala = 1 THEN
    'arpoo uuden palan ja kiinnittää vanhan näyttöön
    IF npalikka.y = 2 THEN GOSUB gameover
    IF npalikka.muoto <> 0 THEN
      FOR i = 1 TO 4
        FOR j = 1 TO 4
          IF palikka(npalikka.muoto, npalikka.suunta, i, j) = 1 THEN
            kentta(npalikka.x + i - 2, npalikka.y + j - 2) = npalikka.muoto
          END IF
        NEXT
      NEXT
    END IF
    npalikka.muoto = INT(RND * 6) + 1
    npalikka.x = 5
    npalikka.y = 1
    npalikka.suunta = 1
    uusipala = 0
  END IF
  IF npalikka.y < KORKEUS - 1 THEN npalikka.y = npalikka.y + 1
  GOSUB paivita
  GOSUB tarkistapoisto
  a = TIMER
  DO
    IF TIMER - a > .5 THEN EXIT DO 'hidaste: mitä pienempi sen nopeampi
    'näppäimistökäsittely: tässä riittää runsaasti parantelemista,
    'sillä koodi ei tarkista, menevätkö siirretyt/käännetyt
    'palikat toisten päälle
    SELECT CASE INKEY$
    CASE CHR$(0) + "K"
      IF npalikka.x > 1 THEN npalikka.x = npalikka.x - 1
    CASE CHR$(0) + "M"
      IF npalikka.x < LEVEYS - 1 THEN npalikka.x = npalikka.x + 1
    CASE CHR$(0) + "P"
      npalikka.y = npalikka.y + 1
    CASE CHR$(0) + "H"
      npalikka.suunta = npalikka.suunta + 1
      IF npalikka.suunta = 5 THEN npalikka.suunta = 1
    CASE "G", "g"
      GOSUB gameover
    CASE CHR$(27)
      END
    END SELECT
  LOOP
LOOP

paivita:

  'päivittää kentän, piirtää ensin pohjan
  'ja sitten liikutettavan palikan

  FOR i = 1 TO LEVEYS
    FOR j = 1 TO KORKEUS
      COLOR kentta(i, j)
      LOCATE j + 1, i + 1: PRINT "█"
    NEXT
  NEXT

  FOR i = 1 TO 4
    FOR j = 1 TO 4
      IF palikka(npalikka.muoto, npalikka.suunta, i, j) = 1 THEN
        LOCATE npalikka.y - 1 + j, npalikka.x - 1 + i
        COLOR npalikka.muoto
        PRINT "█"
        IF kentta(npalikka.x + i - 1 - 1, npalikka.y + j - 1) <> 0 THEN uusipala = 1
        'LOCATE 1, 20: PRINT : SLEEP
        IF npalikka.y + j > KORKEUS + 1 THEN uusipala = 1
      END IF
    NEXT
  NEXT

RETURN

tarkistapoisto:

  'tarkistaa, onko kentällä poistettavia rivejä, ja jos on,
  'poistaa ne

  FOR i = 1 TO KORKEUS
    joo = 1
    FOR j = 1 TO LEVEYS
      IF kentta(j, i) = 0 THEN joo = 0
    NEXT
    IF joo = 1 THEN
      FOR j = i TO 2 STEP -1
        FOR k = 1 TO LEVEYS
          kentta(k, j) = kentta(k, j - 1)
        NEXT
      NEXT
    END IF
  NEXT
RETURN


gameover:

  'tämä löytyy kommenttien kera Ohjelmointiputkasta
  'nimellä Neliöpiirtoefekti

  RANDOMIZE TIMER
  DIM arv(80 * 2, 50 * 2) AS arpa
  FOR i = 1 TO 50 * 2
    FOR j = 1 TO 80 * 2
         arv(j, i).x = j
         arv(j, i).y = i
    NEXT
  NEXT
  FOR i = 1 TO 50 * 80 * 8
    SWAP arv(INT(RND * 80 * 2) + 1, INT(RND * 50 * 2) + 1), arv(INT(RND * 80 * 2) + 1, INT(RND * 50 * 2) + 1)
  NEXT

  DEF SEG = &HA000
  FOR k = 1 TO 200 STEP 2
    FOR h = 1 TO 319 STEP 2
      ix = arv(h \ 2 + 1, k \ 2 + 1).x * 2 - 1
      iy = arv(h \ 2 + 1, k \ 2 + 1).y * 2 - 1
      GOSUB piirrapiste
    NEXT
  NEXT
  DEF SEG

  CLS
  COLOR 4
  PRINT "G A M E  O V E R "
  COLOR 15
  PRINT
  PRINT "Tämän pelin ja kymmeniä muita QBasic-   koodivinkkejä löydät Ohjelmointiputkastaosoitteesta:"
  PRINT
  COLOR 9
  PRINT "https://www.ohjelmointiputka.net"

  END
RETURN

piirrapiste:
  FOR j = ix TO ix + 1
    FOR i = iy TO iy + 1
      t$ = CHR$(0)
      POKE j + (i * 320), ASC(t$)
    NEXT
  NEXT
RETURN


'tässä ovat pelin käyttämät palikat
'niiden muuttaminen lienee yksinkertaista

DATA 0,0,0,0
DATA 0,1,1,0
DATA 0,1,1,0
DATA 0,0,0,0

DATA 0,0,0,0
DATA 0,0,0,0
DATA 1,1,1,1
DATA 0,0,0,0

DATA 0,0,0,0
DATA 1,1,0,0
DATA 0,1,1,0
DATA 0,0,0,0

DATA 0,0,0,0
DATA 0,0,1,1
DATA 0,1,1,0
DATA 0,0,0,0

DATA 0,0,0,0
DATA 0,1,1,1
DATA 0,0,1,0
DATA 0,0,0,0

DATA 0,0,0,0
DATA 0,1,1,1
DATA 0,1,0,0
DATA 0,0,0,0

DATA 0,0,0,0
DATA 1,1,1,0
DATA 0,0,1,0
DATA 0,0,0,0