tsh73+text+mode+tetris+clone

Here's my entry. It is remake of old QBasic program of mine, but I got carried away with a process and program doubled in size ;). It essentially still text-mode program - using LOCATE equivalent and pseudographics. While working I found that my version differs from canonical - for example, extra piece I believe from my Spectrum experience long long time ago. So I tried to change that - and in the prosess, save this as on|off option. So there are bunch of options now. Yes, they are saved then you quit program as preferences. One thing: if you select black on black or white on white, you will not see a thing. Not surprising, really. Just press ESC, Enter and change that in menu.

Really I got fed with it, so two options are unrealised (and thus not selectable) ;)

code format="thinbasic" 'project tetris - lection example. "How we could create big program with subs and functions"

'global variables '... and constants

dim info$(10, 10) global ax, ay, bx, by, w, h, bottom global True, False, GameOver, curFig 'curFig: the rectangle (N7) should not be rotated, that's all. global curKey, kLeft, kRight, kRotate, kDrop, kNothing, aKey$ global movesToDrop, movesPassed, level global flgGoesDown, flgAlreadyDown kLeft = 1: kRight = 2: kRotate = 3: kDrop = 4: kNothing = 0 False = 0 True = NOT(False) w = 10 h = 20 DIM c(h + 2, w) 'just for a case DIM a(5, 5), b(5, 5) DIM aLine$(5) dim colors$(9) '1+ 0..7 pieces global bgColor$, msgColor$, pieceColor$

'colors, for on black colorString$ = "0 240 240,160 0 240,0 240 0,240 0 0,240 160 0,0 0 240,240 240 0,brown,lightgray"

for i = 1 to 9 colors$(i) = word$(colorString$, i, ",") next

global optExtraFigure, optStartHorisontal, optRotateClockwise, optSoftDrop global optBg, optPieceColor, optPieceStyle

'mainwin 80 26  'mimic QBasic text window nomainwin global cw, ch  'char sizes cw=10: ch=18   'measured, for default courier UpperLeftX = 1 UpperLeftY = 1 WindowWidth = 2*4+80*cw WindowHeight = 2*4+40+26*ch

open "Tetris" for graphics_nsb as #gr #gr "trapclose [quit]" #gr "down" #gr "font courier bold"

'main program call initStuff  'Have to read pieces etc menuStateInit$=loadPrefs$ if menuStateInit$ = "" then menuStateInit$="0 0 0 0 1 1 1 0 3 1"

call splash

'main loop: until bored do       gosub [menu] if menuRes then call Game loop until bored 'final thanks #gr "cls" #gr, "backcolor ";bgColor$ #gr, "color ";msgColor$ call printCenter "Thanks for playing our small Tetris!", 12 #gr "when characterInput [quit]" #gr "setfocus" wait 'end is here

SUB askKey 'sets curKey; variants are kLeft, kRight, kRotate, kDrop, kNothing curKey = kNothing a$ = aKey$ aKey$ = ""  'clear key b$ = "" IF LEN(a$) > 1 THEN b$ = MID$(a$, 2, 1) IF a$ = CHR$(27) THEN GameOver = True: EXIT SUB if b$="" then b$=a$ SELECT CASE b$       CASE "a",chr$(_VK_LEFT): curKey = kLeft CASE "d",chr$(_VK_RIGHT): curKey = kRight CASE "w",chr$(_VK_UP): curKey = kRotate CASE "s"," ",chr$(_VK_DOWN): curKey = kDrop END SELECT END SUB

FUNCTION bored 'ask if user bored #gr, "backcolor ";bgColor$ #gr, "color ";msgColor$ call printCenter "Wanna play (Y/N)?", 14 #gr "when characterInput [waitKey1]" #gr "setfocus" wait

[waitKey1] a$=Inkey$ #gr "when characterInput" code = ASC(a$) IF code = 27 OR INSTR("íÍnN", a$) <> 0 THEN bored = True ELSE bored = False END IF   END FUNCTION

FUNCTION canMove 'returns True if array B fits to matrix C, False otherwise. canMove = True FOR j = 1 TO 5 x = bx + j - 1 FOR i = 1 TO 5 y = by + i - 1 IF b(i, j) <> 0 THEN IF x < 1 OR x > w OR y < 1 THEN canMove = False: EXIT FUNCTION IF c(y, x) <> 0 THEN canMove = False: EXIT FUNCTION END IF           NEXT i        NEXT j    END FUNCTION

SUB copyAtoB FOR i = 1 TO 5 FOR j = 1 TO 5 b(i, j) = a(i, j)           NEXT j        NEXT i        bx = ax        by = ay    END SUB

SUB copyBtoA FOR i = 1 TO 5 FOR j = 1 TO 5 a(i, j) = b(i, j)           NEXT j        NEXT i        ax = bx        ay = by    END SUB

SUB createNewFigure 'random one, of 8; set to array a '(actually, to b too, 'cause I gonna draw it immediately) num = INT(RND(1) * (7+optExtraFigure)) '0..7 (or 0..6) curFig = num curColr = num+1 '0 is empty FOR i = 1 TO 5 FOR j = 1 TO 5 IF MID$(aLine$(i), j + 5 * num, 1) <> "." THEN a(i, j) = curColr ELSE a(i, j) = 0 END IF               b(i, j) = a(i, j)            NEXT j        NEXT i        ax = 3 ay = h - 3 bx = ax       by = ay        flgGoesDown = False flgAlreadyDown = False if optStartHorisontal then IF curFig <> 6 THEN call rotateAtoB end if   END SUB

SUB DoStuff 'mainly keyboard handling SELECT CASE curKey CASE kRotate IF curFig <> 6 THEN call rotateAtoB  'O piece could skip rotating CASE kLeft call copyAtoB bx = bx - 1 CASE kRight call copyAtoB bx = bx + 1 CASE kDrop IF NOT(flgAlreadyDown) THEN flgGoesDown = True END IF       END SELECT IF curKey <> kNothing THEN IF canMove THEN call drawFigure END IF       END IF        movesPassed = movesPassed + 1 IF movesPassed > movesToDrop OR flgGoesDown THEN 'dropFigure movesPassed = 0 call copyAtoB by = by - 1 IF canMove THEN call drawFigure ELSE IF flgGoesDown AND NOT(flgAlreadyDown) THEN flgAlreadyDown = True flgGoesDown = False ELSE call figureEnd END IF           END IF            if flgGoesDown and optSoftDrop then flgGoesDown= False END IF   END SUB

SUB drawFigure 'to draw figure. 'Actually, I will: ' clear figure in A ' draw figure in B ' copy b->a #gr, "backcolor ";bgColor$ #gr, "color ";"white" FOR i = 1 TO 5 FOR j = 1 TO 5 IF a(i, j) <> 0 THEN 'clear call JBLOCATE scrY(ay + i - 1), scrX(ax + j - 1) #gr "\";" "; END IF           NEXT j        NEXT i        FOR i = 1 TO 5 FOR j = 1 TO 5 IF b(i, j) <> 0 THEN 'draw call JBLOCATE scrY(by + i - 1), scrX(bx + j - 1) call setPieceColor b(i, j)                   #gr "\";"[]"; END IF           NEXT j        NEXT i        call copyBtoA END SUB

SUB figureEnd 'things to do then we hit the bottom 'put array a to c FOR j = 1 TO 5 x = ax + j - 1 FOR i = 1 TO 5 y = ay + i - 1 IF a(i, j) <> 0 THEN c(y, x) = a(i, j)           NEXT i        NEXT j        'from bottom to top filled = False FOR i = 1 TO h           IF filled THEN i = i - 1'previous line was just deleted '- we should go over it again filled = True FOR j = 1 TO w               IF c(i, j) = 0 THEN filled = False: EXIT FOR NEXT j           IF filled THEN 'remove filled lines #gr, "backcolor ";bgColor$ FOR j = 1 TO w                   call JBLOCATE scrY(i), scrX(j) #gr "\"; " "; NEXT j               call delay 30000, 1 'upper lines go down FOR l = i + 1 TO h                   FOR j = 1 TO w                        c(l - 1, j) = c(l, j)                        call JBLOCATE scrY(l - 1), scrX(j) IF c(l - 1, j) = 0 THEN #gr, "backcolor ";bgColor$ #gr "\"; " "; ELSE call setPieceColor c(l - 1, j)                           #gr "\"; "[]"; END IF                   NEXT j                NEXT l            END IF        NEXT i        call createNewFigure call drawFigure 'can it be moved down? call copyAtoB by = by - 1 IF NOT(canMove) THEN GameOver = True END SUB

SUB Game 'the game, from start to GameOver call GameStart #gr "when characterInput keyCheck" 'wait scan i = 0 DO           call askKey call DoStuff call delay 30000, 1 'pause #gr, "backcolor ";bgColor$ #gr, "color ";msgColor$ i = i + 1: call JBLOCATE 1, 1: #gr "\"; i           IF i MOD 1000 = 0 THEN movesToDrop = movesToDrop - 1 level = level + 1 call JBLOCATE 1, 8 #gr "\"; "Level "; level; END IF       LOOP UNTIL GameOver call showGameOver END SUB

SUB GameStart 'sub for starting the game - initialising, re-drawing screen etc.        'initialising GameOver = False FOR i = 1 TO w           FOR j = 1 TO h                c(j, i) = 0 NEXT j       NEXT i        movesToDrop = 10 level = 1 movesPassed = 0 'create new figure - in array A       call createNewFigure 'preparing screen #gr, "cls" #gr, "fill ";bgColor$ 'the "glass" bottom = 25 RightSide$ = "#0I:" LeftSide$ = ":I0#" call setPieceColor 9 FOR i = 0 TO h           call JBLOCATE bottom - i, 40 - w - 4: #gr "\";LeftSide$; call JBLOCATE bottom - i, 40 + w: #gr "\";RightSide$; NEXT i       FOR i = 1 TO w            call JBLOCATE bottom, 40 - w + 2 * i - 2: #gr "\"; "##"; NEXT i       #gr, "flush" 'draw new figure call drawFigure call JBLOCATE 1, 8 #gr, "backcolor ";bgColor$ #gr, "color ";msgColor$ #gr "\";"Level "; level END SUB

SUB initStuff 'create pieces etc. 'no DATA possible in procedure, so...       'really simple, in 5x5 cells. 'x' means smth, '.' - empty cell. '8 pieces. 'reverse order - 'cause I number lines from 1 up! aLine$(5) = "..x....................................." aLine$(4) = "..x....x....x.....x..xx....xx...xx......" aLine$(3) = "..x....xx...xx...xx...x....x....xx..xx.." aLine$(2) = "..x....x.....x...x....x....x.........x.." aLine$(1) = "........................................" '           1111122222333334444455555666667777788888    END SUB

SUB printCenter a$, l       aLen = LEN(a$) call JBLOCATE l, 1 #gr "\";SPACE$(80) call JBLOCATE l, 40 - aLen / 2 #gr "\";a$ END SUB

SUB rotateAtoB FOR i = 1 TO 5 FOR j = 1 TO 5 if optRotateClockwise then b(i, j) = a(j, 6 - i) 'clockwise else b(i, j) = a(6-j, i) 'counterclockwise end if           NEXT j        NEXT i        bx = ax        by = ay    END SUB

FUNCTION scrX (x) scrX = 40 - w + 2 * x - 2 END FUNCTION

FUNCTION scrY (y) scrY = bottom - y   END FUNCTION

SUB showGameOver #gr, "backcolor ";bgColor$ #gr, "color ";msgColor$ call printCenter "- = * G A M E  O V E R ! = * -", 12 #gr "when characterInput [waitKey3]" #gr "setfocus" wait

[waitKey3] a$=Inkey$ #gr "when characterInput" END SUB

SUB splash 'splash screen #gr "CLS" call printCenter "--==** T E T R I S **==--", 12 #gr "when characterInput [waitKey2]" #gr "setfocus" wait

[waitKey2] a$=Inkey$ #gr "when characterInput" END SUB

'***************************

[quit] timer 0 call savePrefs menuStateInit$ close #gr end

sub keyCheck handle$, key$ aKey$=key$ end sub

sub setPieceColor pieceNum '0 for empty (clearing) select case optPieceColor 'Black:White:Green:Colored case 0 PieceColor$ = "black" case 1 PieceColor$ = "white" 'if optBg = 0 and optPieceStyle<>0 and pieceNum = 9 then PieceColor$ = "darkgray" if optBg = 0 and pieceNum = 9 then PieceColor$ = "darkgray" case 2 PieceColor$ = "darkgreen" if optBg = 0 or (optBg = 1 and optPieceStyle<>0) then PieceColor$ = "green" if pieceNum = 9 then PieceColor$ = "darkgreen" end if       case 3 PieceColor$ = colors$(pieceNum) end select

if pieceNum = 0 then 'empty #gr, "backcolor ";bgColor$ else select case optPieceStyle  'Letters:Inverted Letters:Blocks (no letters)"            case 0                #gr, "backcolor ";bgColor$                #gr, "color ";PieceColor$            case 1                #gr, "backcolor ";PieceColor$                if optBg = 1 and bgColor$ = "white" and optPieceColor<>0 then                    #gr, "color ";"black"                else                    #gr, "color ";bgColor$                end if

case 2 #gr, "backcolor ";PieceColor$ #gr, "color ";PieceColor$ end select end if   end sub

sub delay dummy, delay ' delay is 1/18 th sec timer delay*56, [endDelay] wait

[endDelay] timer 0 end sub

'=========================== 'QB replacement functions/subs

sub JBLOCATE row, col 'locate col, row #gr "place "; cw*col;" ";ch*row print cw*col,ch*row end sub

' some aux functions

function countWords(aStr$, delim$) token$ = "?" while token$ <> "" index = index + 1 token$ = word$(aStr$, index, delim$) '     print token$ wend countWords=index-1 end function

function iif$(test, valYes$, valNo$) iif$ = valNo$ if test then iif$ = valYes$ end function

function iif(test, valYes, valNo) iif = valNo if test then iif = valYes end function

function fileExists(path$, filename$) files path$, filename$, info$ fileExists = val(info$(0, 0)) end function

function loadPrefs$ fileName$= "tetrPref.dat" if fileExists(DefaultDir$,fileName$) then open fileName$ for input as #1 line input #1,prefString$ close #1 else prefString$ = "" end if       loadPrefs$ = prefString$ end function

sub savePrefs prefString$ fileName$= "tetrPref.dat" 'open "d:\";fileName$ for output as #1 on error goto [errorHandler] open fileName$ for output as #1 print #1,prefString$ close #1

[errorHandler] 'fail silently end sub

'++++++++++++++++++++++++++++++++++++ 'menu module - returnable sub

[menu] #gr "fill black" #gr "backcolor black" #gr "color darkgreen"

menuString$="Play|Extra (8th) Piece|Pieces Starting Position|Rotate Direction" menuString$=menuString$+"|(n/a) Preview|(n/a) Freese on contact|Soft drop" menuString$=menuString$+"|Background|Pieces Color|Pieces Style" menuState$="|On:Off|Horisontal:Vertical:(n/a)Random|Clockwise:CounterClockwise" menuState$=menuState$+"|On:Off|On:Off|On:Off" menuState$=menuState$+"|Black:White|Black:White:Green:Colored|Letters:Inverted Letters:Blocks (no letters)"

nItems = countWords(menuString$,"|") dim menuStateNum(nItems), menuState(nItems), menuState$(nItems)

for i = 1 to nItems print word$(menuString$,i,"|") menuState$(i) = word$(menuState$,i,"|") if menuState$(i) = "|" then menuState$(i) = "" print menuState$(i) menuStateNum(i)=countWords(menuState$(i),":") menuState(i)=val(word$(menuStateInit$,i))  'menuState(i) from 0 (for MOD) print "menuStateNum ", menuStateNum(i) next

curItem=1

#gr "when characterInput [waitKey3]" #gr "setfocus"

[drawMenu] top=int((25-nItems*2)/2) #gr "color darkgreen" for i = 1 to nItems msg$ = word$(menuString$,i,"|")+iif$(menuStateNum(i), " : "+word$(menuState$(i),menuState(i)+1,":"), "") call printCenter msg$, i*2+top next i=curItem #gr "color green" msg$ = word$(menuString$,i,"|")+iif$(menuStateNum(i), " : "+word$(menuState$(i),menuState(i)+1,":"), "") call printCenter msg$, i*2+top

wait

[waitKey3] a$ = Inkey$ '  print len(a$), asc(left$(a$,1)), asc(MID$(a$, 2, 1)) b$ = "" IF LEN(a$) > 1 THEN b$ = MID$(a$, 2, 1) IF a$ = CHR$(27) THEN menuRes = 0: goto [menuQuit] IF a$ = CHR$(13) THEN wait  'cause Enter doubles as (13 0) and (0 13), so we skip one of them here (wow!) if b$="" then b$=a$

[moveAgain] SELECT CASE b$   CASE "a",chr$(_VK_LEFT) if menuStateNum(curItem) then menuState(curItem) = (menuState(curItem)+ menuStateNum(curItem)-1) mod menuStateNum(curItem) goto [drawMenu] end if   CASE "d",chr$(_VK_RIGHT)," ",CHR$(13) if curItem = 1 then menuRes = 1: goto [menuQuit] if menuStateNum(curItem) then menuState(curItem) = (menuState(curItem)+1) mod menuStateNum(curItem) goto [drawMenu] end if   CASE "w",chr$(_VK_UP) curItem=(curItem-1+nItems-1) mod nItems +1 if left$(word$(menuString$,curItem,"|"), 5)="(n/a)" then [moveAgain] goto [drawMenu] CASE "s",chr$(_VK_DOWN) curItem=(curItem-1+nItems+1) mod nItems +1 if left$(word$(menuString$,curItem,"|"), 5)="(n/a)" then [moveAgain] goto [drawMenu] END SELECT wait wait

[menuQuit] 'prîcess menu result #gr "when characterInput" if menuRes = 1 then 'set options due to menu optExtraFigure = iif(menuState(2)=0,1,0) optStartHorisontal = iif(menuState(3)=0,1,0) optRotateClockwise = iif(menuState(4)=0,1,0) optSoftDrop = iif(menuState(7)=0,1,0) optBg = menuState(8) bgColor$ = iif$(menuState(8)=0,"black","white") msgColor$ = iif$(menuState(8)=0,"yellow","brown") optPieceColor = menuState(9)   'Black:White:Green:Colored optPieceStyle = menuState(10)  'Letters:Inverted Letters:Blocks (no letters) 'Store menuStateInit$ for next menu run menuStateInit$="" for i = 1 to nItems menuStateInit$=menuStateInit$;menuState(i);" " next else   'eat up some ESC keys #gr "when characterInput [eatEsc1]" wait

[eatEsc1] #gr "when characterInput" end if

return code