'=========================================================================== ' Subject: YA! (YET ANOTHER) TETRIS Date: 07-23-97 (10:12) ' Author: The ABC Programmer Code: QB, QBasic, PDS ' Origin: voxel@freenet.edmonton.ab.ca Packet: GAMES.ABC '=========================================================================== '================[ YA! TETRIS v1.0 Programmed by William Yu ]================= ' ' Release: YA! (Yet Another) TETRIS by William Yu (07-23-97) ' Status: 99% Public Domain, please give credit where due. ' No warranties or guaranteeds applied. ' Use within a commercial product is STRICTLY PROHIBITED! ' Copyrights: TETRIS is now a property of Alexey Pajitnov's TETRIS Co. ' Thanks to: Phillip Jay Cohen for his "Outline Font Routine" (SUB OFONT) ' Contact me: E-mail: voxel@freenet.edmonton.ab.ca ' ' Controls: Keyboard (configurable), check CONSTs ' Joystick (1), or modify the program to support 2. ' ** Watch for conflicting keyboard/joystick values if you ' decide to change the keyboard values. ' If the joystick doesn't seem to work properly, ESC the game ' then run it again. If it still acts up, then change the ' increment/decrement value (20) to something larger, or ' smaller. Try something larger like 30 or 40. ' Gameplay: If you've never played/seen the game before, wow, you're ' just one of the very few. It's a simple game, and for ' some reason, very addictive. You must strategically place ' the "pieces" that fall down, to form complete lines. ' Sounds easy enough, but as the level increases so does the ' speed at which the "pieces" fall down. You can rotate the ' "pieces" clockwise/counter-clockwise and drop them onto the ' playing field to form as many lines as possible, until the ' game tilts, or you have filled the playing field to the ' very top. As each line is complete, that line then becomes ' eliminated from the playing field, and you get points for ' how many lines you eliminate. ' '============================================================================= DECLARE SUB GameOver () DECLARE SUB ShowOccurence () DECLARE SUB SetupScreen () DECLARE SUB ClearKeyBoard () DECLARE SUB Pause (Seconds!) DECLARE SUB PushDown (LineY%) DECLARE SUB CheckLines (GridY%) DECLARE SUB CheckFit (NoFit%, Block%, Cycle%, GridX%, GridY%) DECLARE SUB PutInGrid (Block%, Cycle%, GridX%, GridY%) DECLARE FUNCTION AtBottom% (Block%, Cycle%, GridX%, GridY%) DECLARE FUNCTION MoveBlockLeft% (GridX%, GridY%, Block%, Cycle%) DECLARE FUNCTION MoveBlockRight% (GridX%, GridY%, Block%, Cycle%) DECLARE SUB PutBlock (X%, Y%, Block%, Cycle%) DECLARE SUB DrawBlock (X%, Y%, Hue%) DECLARE SUB GetShapes () DECLARE SUB InitVariables () DECLARE SUB OFont (Text$, X%, Y%, Fore%, Back%) DECLARE SUB DefinePalette () DECLARE SUB Pal (C%, R%, G%, B%) DEFINT A-Z '$DYNAMIC SCREEN 13 OPTION BASE 1 CONST False = 0 CONST True = NOT False '------------ USER Defined ------------ CONST UseJoy = False '' Use joystick (not recommended for slow machines) CONST Left = -75 '' Left Arrow CONST Right = -77 '' Right Arrow CONST Rotate = -72 '' Up Arrow CONST OppRotate = 13 '' Enter key: Counter-clockwise CONST Drop = 32 '' Space CONST DropSlow = -80 '' Down Arrow CONST GridWidth = 10 CONST GridHeight = 20 CONST BlockWidth = 11 CONST BlockHeight = 9 CONST NextLevel = 25 CONST StdScore = 50 '' Standard Score/line CONST LevelX = 5 '' Add to Standard Score CONST ScoreX = 0 '' Bonus Score/line CONST Score2X = 25 CONST Score3X = 50 CONST Score4X = 100 '' Bonus Score/Tetris (4 lines) CONST Decr! = .05 '' Decrease delay by this decrement '-------------------------------------- CONST Array = 4 * BlockWidth * BlockHeight + 2 DIM SHARED Piece(7, 8) AS INTEGER DIM SHARED Occur(7) AS INTEGER DIM SHARED Grid(0 TO GridWidth, 0 TO GridHeight) AS INTEGER DIM SHARED Colour(3 * 8) AS INTEGER DIM SHARED Shape(7 * 4 * Array) AS INTEGER 'DIM SHARED GridX, GridY, Block,Cycle DIM SHARED StartX, StartY, EndY, EndX, NumLines, Score&, LinesLeft, Level!, Delay!, NumBlocks& StartX = 2 * GridWidth StartY = 10 EndX = StartX + BlockWidth * GridWidth + 1 EndY = StartY + BlockHeight * GridHeight InitVariables IF UseJoy THEN JoyStickX = STICK(0) JoyStickY = STICK(1) Free = True END IF RANDOMIZE TIMER NumLines = 0 NumBlocks& = 1 LinesLeft = NextLevel Level! = 0 GridX = 4 GridY = 1 Cycle = 1 Block = INT(RND * 7) + 1 Occur(Block) = Occur(Block) + 1 InitDrop = False NextBlock = INT(RND * 7) + 1 SetupScreen '' Draw gameplay screen PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle ShapeArray = (NextBlock - 1) * 4 * Array + 1 PUT (EndX + 20 + BlockWidth, 30 + BlockHeight), Shape(ShapeArray), PSET Delay! = .9 - (Level! * Decr!) IF Delay! < .02 THEN Delay! = .018 T! = TIMER DO DO A$ = INKEY$ IF InitDrop THEN A$ = "" PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle GOSUB DropBlock PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle ELSEIF TIMER - T! >= Delay! THEN T! = TIMER PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle GOSUB DropBlock PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle END IF IF UseJoy THEN IF STICK(1) > JoyStickY + 20 THEN A$ = CHR$(0) + "P" SELECT CASE STICK(0) CASE IS < JoyStickX - 20 A$ = CHR$(0) + "K" CASE IS > JoyStickX + 20 A$ = CHR$(0) + "M" END SELECT A = STRIG(1) B = STRIG(5) IF Free AND A AND B = 0 THEN A$ = CHR$(0) + "H" Free = False ELSE IF A = 0 AND B = 0 THEN Free = True END IF IF Free AND B AND A = 0 THEN A$ = CHR$(13) Free = False ELSE IF A = 0 AND B = 0 THEN Free = True END IF END IF LOOP UNTIL LEN(A$) IF LEN(A$) = 2 THEN Char = -ASC(RIGHT$(A$, 1)) ELSE Char = ASC(A$) PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle SELECT CASE Char CASE Left IF MoveBlockLeft%(GridX, GridY, Block, Cycle) THEN CheckFit NoFit, Block, Cycle, GridX - 1, GridY - 1 IF NOT NoFit THEN GridX = GridX - 1 END IF CASE Right IF MoveBlockRight%(GridX, GridY, Block, Cycle) THEN CheckFit NoFit, Block, Cycle, GridX + 1, GridY - 1 IF NOT NoFit THEN GridX = GridX + 1 END IF CASE Rotate, OppRotate TempCycle = Cycle TempX = GridX TempY = GridY SELECT CASE Cycle CASE 1 IF Char = Rotate THEN Cycle = 2 ELSE Cycle = 4 GridX = GridX + 1 ' Offset my bad programming IF GridY - 1 = 0 THEN GridY = 1 ELSE GridY = GridY - 1 CASE 2 IF Char = Rotate THEN Cycle = 3 ELSE Cycle = 1 GridX = GridX - 1 GridY = GridY + 1 IF GridX < 1 THEN IF Char = Rotate THEN IF Piece(Block, 4) = 1 OR Piece(Block, 8) = 1 THEN GridX = 1 ELSE IF Piece(Block, 1) = 1 OR Piece(Block, 5) = 1 THEN GridX = 1 END IF ELSEIF GridX + 3 > GridWidth THEN IF Char = Rotate THEN IF Piece(Block, 1) = 1 OR Piece(Block, 5) = 1 THEN GridX = GridX - 1 ELSE IF Piece(Block, 4) = 1 OR Piece(Block, 8) = 1 THEN GridX = GridX - 1 END IF END IF CASE 3 IF Char = Rotate THEN Cycle = 4 ELSE Cycle = 2 GridX = GridX + 1 GridY = GridY - 1 CASE 4 IF Char = Rotate THEN Cycle = 1 ELSE Cycle = 3 GridX = GridX - 1 GridY = GridY + 1 IF GridX < 1 THEN IF Char = OppRotate THEN IF Piece(Block, 4) = 1 OR Piece(Block, 8) = 1 THEN GridX = 1 ELSE IF Piece(Block, 1) = 1 OR Piece(Block, 5) = 1 THEN GridX = 1 END IF ELSEIF GridX + 3 > GridWidth THEN IF Char = OppRotate THEN IF Piece(Block, 1) = 1 OR Piece(Block, 5) = 1 THEN GridX = GridX - 1 IF Block = 1 THEN GridX = GridX - 1 '' Oh the heck with it! :) ELSE IF Piece(Block, 4) = 1 OR Piece(Block, 8) = 1 THEN GridX = GridX - 1 IF Block = 1 THEN GridX = GridX - 1 END IF END IF END SELECT IF (GridY >= 19 AND Cycle = 2) OR (GridY >= 19 AND Cycle = 4) THEN NoFit = True ELSE CheckFit NoFit, Block, Cycle, GridX, GridY - 1 END IF IF NoFit THEN '' Cannot rotate, so restore previous values Cycle = TempCycle GridX = TempX GridY = TempY END IF CASE Drop InitDrop = True CASE DropSlow GOSUB DropBlock END SELECT PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle LOOP UNTIL Char = 27 END DropBlock: IF AtBottom%(Block, Cycle, GridX, GridY) THEN NoFit = True GridY = GridY + 1 ELSE CheckFit NoFit, Block, Cycle, GridX, GridY END IF IF NoFit THEN GOSUB PlaceBlock RETURN PlaceBlock: InitDrop = False GridY = GridY - 1 PutInGrid Block, Cycle, GridX, GridY PutBlock StartX + (GridX - 1) * BlockWidth + 1, (GridY - 1) * BlockHeight + 1, Block, Cycle IF GridY = 1 THEN CALL GameOver: END CheckLines GridY - 1 GridX = 4: GridY = 1 Block = NextBlock: Cycle = 1 Occur(Block) = Occur(Block) + 1 NumBlocks& = NumBlocks& + 1 ShowOccurence NextBlock = INT(RND * 7) + 1 ShapeArray = (NextBlock - 1) * 4 * Array + 1 PUT (EndX + 20 + BlockWidth, 30 + BlockHeight), Shape(ShapeArray), PSET T! = TIMER ClearKeyBoard RETURN ' No more than 7, and the pieces MUST BE at least 3 blocks in length ' Data for Style 1: Long DATA 1,1,1,1 DATA 0,0,0,0 ' Data for Style 2: L Right DATA 1,1,1,0 DATA 0,0,1,0 ' Data for Style 3: L Left DATA 0,1,1,1 DATA 0,1,0,0 ' Data for Style 4: Z Right DATA 1,1,0,0 DATA 0,1,1,0 ' Data for Style 5: Z Left DATA 0,1,1,0 DATA 1,1,0,0 ' Data for Style 6: T DATA 1,1,1,0 DATA 0,1,0,0 ' Data for Style 7: Square DATA 0,1,1,0 DATA 0,1,1,0 REM $STATIC FUNCTION AtBottom% (Block, Cycle, GridX, GridY) '************************************************************* ' Function: Check if Block has reached the bottom of the well ' Returns: True if cannot move down farther ' False otherwise '************************************************************* AtBottom% = False SELECT CASE Cycle CASE 2 IF GridY = GridHeight - 2 THEN IF Piece(Block, 4) = 1 OR Piece(Block, 8) = 1 THEN AtBottom% = True ELSEIF GridY = GridHeight - 1 THEN AtBottom% = True END IF CASE 4 IF GridY = GridHeight - 2 THEN IF Piece(Block, 1) = 1 OR Piece(Block, 5) = 1 THEN AtBottom% = True ELSEIF GridY = GridHeight - 1 THEN AtBottom% = True END IF CASE ELSE IF GridY = GridHeight + 1 AND Cycle = 1 AND Block = 1 THEN AtBottom% = True ELSEIF GridY = GridHeight AND Block = 1 AND Cycle = 1 THEN FOR I = 1 TO 4 IF Piece(Block, I + 4) = 1 AND Grid(GridX - 1 + I, GridY) = 1 THEN AtBottom% = True NEXT I ELSEIF GridY = 19 AND Block = 1 AND Cycle = 3 THEN FOR I = 1 TO 4 IF Piece(Block, 5 - I) = 1 AND Grid(GridX - 1 + I, GridY + 1) = 1 THEN AtBottom% = True NEXT I ELSEIF GridY = GridHeight AND Block <> 1 THEN AtBottom% = True END IF END SELECT END FUNCTION SUB CheckFit (NoFit, Block, Cycle, GridX, GridY) '***************************************************************** ' Function: Check if Block fits into position without overlapping ' Returns: NoFit is True if the Block cannot fit ' NoFit is False otherwise '***************************************************************** NoFit = False IF GridY <= GridHeight THEN GridY = GridY + 1 SELECT CASE Cycle '' Check if block fits CASE 1, 3 IF Block = 1 THEN FOR I = 1 TO 4 IF Cycle = 1 THEN IF GridX - 1 + I < GridWidth + 1 THEN IF Piece(Block, I) = 1 AND Grid(GridX - 1 + I, GridY - 1) = 1 THEN NoFit = True END IF ELSE IF GridY = GridHeight + 1 THEN NoFit = True ELSE IF GridX - 1 + I < GridWidth + 1 THEN IF Piece(Block, 5 - I) = 1 AND Grid(GridX - 1 + I, GridY) = 1 THEN NoFit = True END IF END IF END IF IF NoFit THEN EXIT FOR NEXT I ELSE FOR I = 1 TO 4 IF Cycle = 1 THEN IF GridX - 1 + I < GridWidth + 1 THEN IF Piece(Block, I) = 1 AND Grid(GridX - 1 + I, GridY - 1) = 1 THEN NoFit = True IF GridY < GridHeight + 1 THEN IF Piece(Block, I + 4) = 1 AND Grid(GridX - 1 + I, GridY) = 1 THEN NoFit = True END IF ELSE IF GridX - 1 + I < GridWidth + 1 THEN IF GridY < GridHeight + 1 THEN IF Piece(Block, 9 - I) = 1 AND Grid(GridX - 1 + I, GridY - 1) = 1 THEN NoFit = True IF Piece(Block, 5 - I) = 1 AND Grid(GridX - 1 + I, GridY) = 1 THEN NoFit = True END IF END IF END IF IF NoFit THEN EXIT FOR NEXT I END IF CASE 2, 4 FOR I = 1 TO 4 IF Cycle = 2 THEN IF GridX <> 0 THEN IF GridY + I - 2 < GridHeight + 1 THEN IF Piece(Block, I + 4) = 1 AND Grid(GridX, GridY + I - 2) = 1 THEN NoFit = True END IF END IF IF GridY + I - 2 < GridHeight + 1 THEN IF Piece(Block, I) = 1 AND Grid(GridX + 1, GridY + I - 2) = 1 THEN NoFit = True END IF ELSE IF GridY + I - 2 < GridHeight + 1 AND GridY > 0 THEN IF Piece(Block, 5 - I) = 1 AND Grid(GridX, GridY + I - 2) = 1 THEN NoFit = True IF GridX < GridWidth THEN IF Piece(Block, 9 - I) = 1 AND Grid(GridX + 1, GridY + I - 2) = 1 THEN NoFit = True END IF END IF END IF IF NoFit THEN EXIT FOR NEXT I END SELECT END IF END SUB SUB CheckLines (GridY) '********************************************************* ' Function: Check if user has any lines completed ' Starts from bottom up until GridY is reached. ' Display: Removes line and displays scores and stats ' Returns: None '********************************************************* REDIM Well(20000) AS INTEGER ' Depends on your GridWidth/BlockWidth, etc. Y = GridHeight '' Start from bottom up TempLines = NumLines '' Used as an indicator to how many lines completed DO NoLine = False FOR J = 1 TO GridWidth IF Grid(J, Y) = 0 THEN NoLine = True: EXIT FOR NEXT J IF NoLine = False THEN FOR J = 1 TO GridWidth DrawBlock StartX + (J - 1) * BlockWidth + 1, StartY + (Y - 1) * BlockHeight, 22 NEXT J GET (StartX + 1, StartY)-(StartX + GridWidth * BlockWidth, StartY + (Y - 1) * BlockHeight - 1), Well Pause .15 LINE (StartX + 1, StartY + (Y - 1) * BlockHeight)-(StartX + GridWidth * BlockWidth, StartY + Y * BlockHeight - 1), 0, BF '' Cool Drop 'FOR K = StartY TO StartY + BlockHeight ' PUT (StartX + 1, K), Well, PSET 'NEXT K PUT (StartX + 1, StartY + BlockHeight), Well, PSET PushDown Y Y = Y + 1 END IF Y = Y - 1 LOOP UNTIL Y = GridY - 1 '' Display all relevant scores and statistics. IF NumLines > TempLines THEN '' If player has at least one line filled '' Display number of lines eliminated A$ = LTRIM$(STR$(NumLines)) A$ = STRING$(4 - LEN(A$), "0") + A$ LINE (EndX + 30, 30 + 5 * BlockHeight + 75)-(EndX + 80, 30 + 5 * BlockHeight + 82), 23, BF OFont A$, EndX + 46, 30 + 5 * BlockHeight + 75, 1, 3 '' Display player score SELECT CASE NumLines - TempLines CASE 1 Score& = Score& + ScoreX CASE 2 Score& = Score& + Score2X CASE 3 Score& = Score& + Score3X CASE 4 Score& = Score& + Score4X END SELECT A$ = LTRIM$(STR$(Score&)) A$ = STRING$(6 - LEN(A$), "0") + A$ LINE (EndX + 30, 30 + 5 * BlockHeight + 15)-(EndX + 80, 30 + 5 * BlockHeight + 22), 23, BF OFont A$, EndX + 30, 30 + 5 * BlockHeight + 15, 1, 3 '' Display number of lines left until next level reached IF NumLines >= LinesLeft THEN LinesLeft = LinesLeft + NextLevel Level! = Level! + 1 Delay! = Delay! - Decr! IF Delay! < .02 THEN Delay! = .018 A$ = LTRIM$(STR$(Level!)) A$ = STRING$(3 - LEN(A$), "0") + A$ LINE (EndX + 30, 30 + 5 * BlockHeight + 45)-(EndX + 80, 30 + 5 * BlockHeight + 52), 23, BF OFont A$, EndX + 54, 30 + 5 * BlockHeight + 45, 1, 3 END IF A$ = LTRIM$(STR$(LinesLeft - NumLines)) A$ = STRING$(4 - LEN(A$), "0") + A$ LINE (EndX + 30, 30 + 5 * BlockHeight + 105)-(EndX + 80, 30 + 5 * BlockHeight + 112), 23, BF OFont A$, EndX + 46, 30 + 5 * BlockHeight + 105, 1, 3 END IF ERASE Well END SUB SUB ClearKeyBoard ' Clears keyboard buffer DO: LOOP UNTIL INKEY$ = "" END SUB SUB DefinePalette ' Function: Changes palette scheme ' Blue Pal 1, 0, 0, 50 Pal 2, 0, 0, 30 Pal 3, 0, 0, 20 ' Red Pal 4, 50, 0, 0 Pal 5, 30, 0, 0 Pal 6, 20, 0, 0 ' Green Pal 7, 0, 50, 0 Pal 8, 0, 30, 0 Pal 9, 0, 20, 0 ' Cyan Pal 10, 0, 50, 50 Pal 11, 0, 30, 30 Pal 12, 0, 20, 20 ' Purple Pal 13, 50, 0, 50 Pal 14, 30, 0, 30 Pal 15, 20, 0, 20 ' Yellow Pal 16, 55, 55, 0 Pal 17, 35, 35, 0 Pal 18, 25, 25, 0 ' Orange Pal 19, 63, 45, 0 Pal 20, 43, 25, 0 Pal 21, 33, 15, 0 ' White Pal 22, 55, 55, 55 Pal 23, 35, 35, 35 Pal 24, 25, 25, 25 Pal 25, 63, 63, 63 END SUB SUB DrawBlock (X, Y, Hue) ' Function: Draw one square block at X,Y with palette Hue. LINE (X, Y)-(X + BlockWidth - 1, Y + BlockHeight - 1), Colour(Hue), BF 'Bottom Shadow LINE (X, Y + BlockHeight - 1)-(X + BlockWidth - 1, Y + BlockHeight - 1), Colour(Hue + 2) LINE (X + 1, Y + BlockHeight - 2)-(X + BlockWidth - 2, Y + BlockHeight - 2), Colour(Hue + 2) 'Right Shadow LINE (X + BlockWidth - 1, Y)-(X + BlockWidth - 1, Y + BlockHeight - 1), Colour(Hue + 2) LINE (X + BlockWidth - 2, Y + 1)-(X + BlockWidth - 2, Y + BlockHeight - 2), Colour(Hue + 2) 'Top Shadow LINE (X, Y)-(X + BlockWidth - 1, Y), Colour(Hue + 1) LINE (X + 1, Y + 1)-(X + BlockWidth - 2, Y + 1), Colour(Hue + 1) 'Left Shadow LINE (X, Y)-(X, Y + BlockHeight - 1), Colour(Hue + 1) LINE (X + 1, Y + 1)-(X + 1, Y + BlockHeight - 2), Colour(Hue + 1) END SUB SUB GameOver SLEEP 1 LINE (StartX + 1, 0)-(StartX + 10 * BlockWidth, StartY), 0, BF OFont "GAME OVER", StartX + 19, 1, 1, 3 FOR Y = StartY TO EndY - BlockHeight STEP BlockHeight Pause .018 FOR X = StartX + 1 TO EndX - BlockWidth STEP BlockWidth DrawBlock X, Y, 22 NEXT X NEXT Y END SUB SUB GetShapes ' Function: Draw all shapes and store them in Shape() for easy retrieval FOR I = 1 TO 7 Hue = (I - 1) * 3 + 1 StartArray = (I - 1) * 4 * Array + 1 FOR K = 1 TO 4 LINE (0, 0)-(4 * BlockWidth - 1, 4 * BlockHeight - 1), 0, BF X = 0 Y = 0 N = 0 SELECT CASE K CASE 1 FOR J = 1 TO 8 IF J = 5 THEN Y = Y + BlockHeight: N = 0 IF Piece(I, J) = 1 THEN DrawBlock X + (N * BlockWidth), Y, Hue END IF N = N + 1 NEXT J GET (0, 0)-(4 * BlockWidth - 1, 2 * BlockHeight - 1), Shape(StartArray) CASE 2 FOR J = 1 TO 4 IF Piece(I, J) = 1 THEN DrawBlock X + BlockWidth, Y, Hue IF Piece(I, J + 4) = 1 THEN DrawBlock X, Y, Hue Y = Y + BlockHeight NEXT J GET (0, 0)-(2 * BlockWidth - 1, 4 * BlockHeight - 1), Shape(StartArray + (K - 1) * Array) CASE 3 FOR J = 4 TO 1 STEP -1 IF Piece(I, J) = 1 THEN DrawBlock X + (N * BlockWidth), Y + BlockHeight, Hue IF Piece(I, J + 4) = 1 THEN DrawBlock X + (N * BlockWidth), Y, Hue N = N + 1 NEXT J GET (0, 0)-(4 * BlockWidth - 1, 2 * BlockHeight - 1), Shape(StartArray + (K - 1) * Array) CASE 4 FOR J = 4 TO 1 STEP -1 IF Piece(I, J) = 1 THEN DrawBlock X, Y, Hue IF Piece(I, J + 4) = 1 THEN DrawBlock X + BlockWidth, Y, Hue Y = Y + BlockHeight NEXT J GET (0, 0)-(2 * BlockWidth - 1, 4 * BlockHeight - 1), Shape(StartArray + (K - 1) * Array) END SELECT NEXT K NEXT I END SUB SUB InitVariables ' Function: Initialize all relevant variables for gameplay FOR I = 1 TO 7 FOR J = 1 TO 8 READ Piece(I, J) NEXT J NEXT I FOR I = 1 TO 3 * 8 Colour(I) = I NEXT I FOR I = 1 TO 3 * 8 '' Hide what I'm doing Pal I, 0, 0, 0 NEXT I GetShapes LINE (0, 0)-(319, 199), 0, BF '' cls DefinePalette END SUB FUNCTION MoveBlockLeft% (GridX, GridY, Block, Cycle) '**************************************************************** ' Function: Check if Block can be moved one position to the left ' Returns: True if no overlap ' False otherwise '**************************************************************** MoveBlockLeft% = False SELECT CASE Cycle CASE 1 '' Horizontal, so check left side IF GridX <= 1 THEN IF Piece(Block, ABS(GridX - 2)) = 0 AND Piece(Block, ABS(GridX - 6)) = 0 THEN MoveBlockLeft% = True ELSE MoveBlockLeft% = True END IF CASE 2 '' Vertical, so check bottom side IF GridX <> 0 THEN IF GridX = 1 THEN NoMore = False FOR I = 5 TO 8 IF Piece(Block, I) = 1 THEN NoMore = True: EXIT FOR NEXT I IF NoMore = False THEN MoveBlockLeft% = True ELSE MoveBlockLeft% = True END IF END IF CASE 3 '' Horizontal #2, so check right side IF GridX <= 1 THEN IF Piece(Block, GridX + 3) = 0 AND Piece(Block, GridX + 7) = 0 THEN MoveBlockLeft% = True ELSE MoveBlockLeft% = True END IF CASE 4 '' Vertical #2, so check top side IF GridX <> 0 THEN IF GridX = 1 THEN NoMore = False FOR I = 1 TO 4 IF Piece(Block, I) = 1 THEN NoMore = True: EXIT FOR NEXT I IF NoMore = False THEN MoveBlockLeft% = True ELSE MoveBlockLeft% = True END IF END IF END SELECT END FUNCTION FUNCTION MoveBlockRight% (GridX, GridY, Block, Cycle) '***************************************************************** ' Function: Check if Block can be moved one position to the right ' Returns: True if no overlap ' False otherwise '***************************************************************** MoveBlockRight% = False SELECT CASE Cycle CASE 1 '' Horizontal, so check right side IF GridX + 3 >= GridWidth THEN IF Piece(Block, GridWidth - GridX + 1) = 0 AND Piece(Block, GridWidth - GridX + 5) = 0 THEN MoveBlockRight% = True ELSE MoveBlockRight% = True END IF CASE 2 '' Vertical, so check top side IF GridX <> GridWidth THEN IF GridX = GridWidth - 1 THEN NoMore = False FOR I = 1 TO 4 IF Piece(Block, I) = 1 THEN NoMore = True: EXIT FOR NEXT I IF NoMore = False THEN MoveBlockRight% = True ELSE MoveBlockRight% = True END IF END IF CASE 3 '' Horizontal #2, so check left side IF GridX + 3 >= GridWidth THEN IF Piece(Block, ABS(GridWidth - GridX - 4)) = 0 AND Piece(Block, ABS(GridWidth - GridX - 8)) = 0 THEN MoveBlockRight% = True ELSE MoveBlockRight% = True END IF CASE 4 '' Vertical #2, so check bottom side IF GridX <> GridWidth THEN IF GridX = GridWidth - 1 THEN NoMore = False FOR I = 5 TO 8 IF Piece(Block, I) = 1 THEN NoMore = True: EXIT FOR NEXT I IF NoMore = False THEN MoveBlockRight% = True ELSE MoveBlockRight% = True END IF END IF END SELECT END FUNCTION SUB OFont (Text$, X, Y, Fore, Back) DEF SEG = &HFFA6 'Stores masks for letters FOR Letter = 1 TO LEN(Text$) 'Does each letter Address = (8 * ASC(MID$(Text$, Letter))) + 14 'Address for start of letter FOR Height = 0 TO 7 'Each letter is an 8x8 pixel matrix Mask = PEEK(Address + Height) * 128 'Address for mask of each line of letter LINE (X + Curntx + 1, Y + Height + 1)-(X + 9 + Curntx, Y + Height + 1), Fore, , Mask NEXT Curntx = Curntx + 8 'Advances X axis by 8 for next letter NEXT 'Continue to next letter DEF SEG = &HA000 'Change to video memory IF Back > 0 THEN 'Background color can't be color 0 FOR V = Y TO Y + 7 'Again, they're 8x8 pixels FOR H = X TO (LEN(Text$) * 8) - 1 + X 'Calculates length of text in pixels PK0& = PEEK(H + V * 320&) 'Is point at H,V = to foreground color? PK1& = PEEK(H + 1 + (V + 1) * 320&) 'Is point at H+1, V+1 = to foreground? PK2& = PEEK(H + 1 + V * 320&) 'Is point at H+1, V = to foreground? PT& = H + V * 320& 'Video memory pointer IF PK0& <> Fore THEN 'If this is foreground, don't overlap it IF PK1& = Fore OR PK2& = Fore THEN POKE PT&, Back 'Put pixel into memory END IF NEXT H 'Next horizontal NEXT V 'Next vertical END IF DEF SEG 'Put us back where END SUB SUB Pal (C, R, G, B) OUT &H3C8, C OUT &H3C9, R OUT &H3C9, G OUT &H3C9, B END SUB SUB Pause (Seconds!) T! = TIMER DO LOOP UNTIL ABS(TIMER - T!) >= Seconds! END SUB SUB PushDown (LineY) ' Function: Clear LineY from grid, update numlines and score FOR J = 1 TO GridWidth Grid(J, LineY) = 0 NEXT J FOR I = LineY TO 2 STEP -1 FOR J = 1 TO GridWidth SWAP Grid(J, I), Grid(J, I - 1) NEXT J NEXT I NumLines = NumLines + 1 Score& = Score& + StdScore + (Level! * LevelX) END SUB SUB PutBlock (X, Y, Block, Cycle) ' Function: Place Block at X,Y ShapeArray = (Block - 1) * 4 * Array + 1 + ((Cycle - 1) * Array) IF Y > 0 THEN PUT (X, Y), Shape(ShapeArray), XOR '' Overlap is okay END IF END SUB SUB PutInGrid (Block, Cycle, GridX, GridY) '********************************************* ' Function: Occupy (fill) grid with block ' Returns: None '********************************************* SELECT CASE Cycle '' Fill grid with block CASE 1, 3 IF GridY - 1 = GridHeight THEN FOR I = 1 TO 4 IF Cycle = 1 THEN IF Piece(Block, I) = 1 THEN Grid(GridX - 1 + I, GridY - 1) = 1 ELSE IF Piece(Block, 5 - I) = 1 THEN Grid(GridX - 1 + I, GridY - 1) = 1 END IF NEXT I ELSE FOR I = 1 TO 4 IF Cycle = 1 THEN IF Piece(Block, I) = 1 THEN Grid(GridX - 1 + I, GridY - 1) = 1 IF Piece(Block, I + 4) = 1 THEN Grid(GridX - 1 + I, GridY) = 1 ELSE IF Piece(Block, 9 - I) = 1 THEN Grid(GridX - 1 + I, GridY - 1) = 1 IF Piece(Block, 5 - I) = 1 THEN Grid(GridX - 1 + I, GridY) = 1 END IF NEXT I END IF CASE 2, 4 FOR I = 1 TO 4 IF Cycle = 2 THEN IF GridX <> 0 THEN IF Piece(Block, I + 4) = 1 THEN Grid(GridX, (GridY + I - 2)) = 1 END IF IF Piece(Block, I) = 1 THEN Grid(GridX + 1, GridY + I - 2) = 1 ELSE IF Piece(Block, 5 - I) = 1 THEN Grid(GridX, GridY + I - 2) = 1 IF GridX <> GridHeight THEN IF Piece(Block, 9 - I) = 1 THEN Grid(GridX + 1, GridY + I - 2) = 1 END IF END IF NEXT I END SELECT ' If you wish to do some debugging... 'FOR I = 1 TO GridHeight 'FOR J = 1 TO GridWidth ' LOCATE I, 19 + J ' IF Grid(J, I) = 1 THEN PRINT "X"; ELSE PRINT "O"; 'NEXT J 'NEXT I END SUB SUB SetupScreen ' Function: Create gameplay screen LINE (0, 0)-(StartX - 2, 199), 23, BF LINE (EndX + 2, 0)-(319, 199), 23, BF LINE (0, EndY + 2)-(EndX + 1, 199), 23, BF LINE (0, 0)-(StartX - 2, 0), 25 LINE (0, 0)-(0, 199), 25 LINE (StartX, EndY + 2)-(EndX + 1, EndY + 2), 25 LINE (EndX + 2, 0)-(EndX + 2, EndY + 2), 25 LINE (EndX + 2, 0)-(319, 0), 25 LINE (StartX - 2, 1)-(StartX - 2, EndY + 2), 24 LINE (0, 199)-(319, 199), 24 LINE (319, 1)-(319, 199), 24 'Text$ = "YA TETRIS" 'FOR I = 1 TO LEN(Text$) ' OFont MID$(Text$, I, 1), 4, 10 + (I - 1) * 10, 22, 24 'NEXT I OFont "YA!", EndX + 12, 10, 1, 3 OFont "TETRIS", EndX + 42, 10, 10, 12 LINE (EndX + 105, 5)-(EndX + 180, 22), 25, B LINE (EndX + 105, 5)-(EndX + 180, 5), 24 LINE (EndX + 105, 5)-(EndX + 105, 22), 24 OFont "STANDARD", EndX + 110, 10, 4, 6 LINE (EndX + 25, 30 + 5 * BlockHeight + 12)-(EndX + 83, 30 + 5 * BlockHeight + 25), 25, B LINE (EndX + 25, 30 + 5 * BlockHeight + 12)-(EndX + 83, 30 + 5 * BlockHeight + 12), 24 LINE (EndX + 25, 30 + 5 * BlockHeight + 12)-(EndX + 25, 30 + 5 * BlockHeight + 25), 24 OFont "Score", EndX + 30, 30 + 5 * BlockHeight, 25, 24 LINE (EndX + 25, 30 + 5 * BlockHeight + 42)-(EndX + 83, 30 + 5 * BlockHeight + 55), 25, B LINE (EndX + 25, 30 + 5 * BlockHeight + 42)-(EndX + 83, 30 + 5 * BlockHeight + 42), 24 LINE (EndX + 25, 30 + 5 * BlockHeight + 42)-(EndX + 25, 30 + 5 * BlockHeight + 55), 24 OFont "Level", EndX + 30, 30 + 5 * BlockHeight + 30, 25, 24 LINE (EndX + 25, 30 + 5 * BlockHeight + 72)-(EndX + 83, 30 + 5 * BlockHeight + 85), 25, B LINE (EndX + 25, 30 + 5 * BlockHeight + 72)-(EndX + 83, 30 + 5 * BlockHeight + 72), 24 LINE (EndX + 25, 30 + 5 * BlockHeight + 72)-(EndX + 25, 30 + 5 * BlockHeight + 85), 24 OFont "Lines", EndX + 30, 30 + 5 * BlockHeight + 60, 25, 24 LINE (EndX + 25, 30 + 5 * BlockHeight + 102)-(EndX + 83, 30 + 5 * BlockHeight + 115), 25, B LINE (EndX + 25, 30 + 5 * BlockHeight + 102)-(EndX + 83, 30 + 5 * BlockHeight + 102), 24 LINE (EndX + 25, 30 + 5 * BlockHeight + 102)-(EndX + 25, 30 + 5 * BlockHeight + 115), 24 OFont "Left", EndX + 30, 30 + 5 * BlockHeight + 90, 25, 24 OFont "000000", EndX + 30, 30 + 5 * BlockHeight + 15, 1, 3 A$ = LTRIM$(STR$(Level!)) A$ = STRING$(3 - LEN(A$), "0") + A$ OFont A$, EndX + 54, 30 + 5 * BlockHeight + 45, 1, 3 OFont "0000", EndX + 46, 30 + 5 * BlockHeight + 75, 1, 3 A$ = LTRIM$(STR$(LinesLeft)) A$ = STRING$(4 - LEN(A$), "0") + A$ OFont A$, EndX + 46, 30 + 5 * BlockHeight + 105, 1, 3 ShowOccurence LINE (EndX + 20, 30)-(EndX + 20 + 6 * BlockWidth, 30 + 4 * BlockHeight), 0, BF LINE (EndX + 20, 30)-(EndX + 20 + 6 * BlockWidth, 30 + 4 * BlockHeight), 25, B LINE (EndX + 20, 30)-(EndX + 20 + 6 * BlockWidth, 30), 24 LINE (EndX + 20, 30)-(EndX + 20, 30 + 4 * BlockHeight), 24 LINE (StartX, StartY)-(StartX, EndY), 24 LINE (StartX, EndY)-(EndX, EndY), 24 LINE (EndX, StartY)-(EndX, EndY), 24 END SUB SUB ShowOccurence ' Function: Display block statistics L = EndY - 30 '' Length of line LINE (EndX + 110, 30)-(EndX + 200, EndY), 23, BF FOR I = 1 TO 7 LINE (EndX + 110 + (I - 1) * 10, EndY)-(EndX + 115 + (I - 1) * 10, EndY - Occur(I) / NumBlocks& * L), (I - 1) * 3 + 1, BF LINE (EndX + 110 + (I - 1) * 10, EndY)-(EndX + 110 + (I - 1) * 10, EndY - Occur(I) / NumBlocks& * L), (I - 1) * 3 + 2 LINE (EndX + 110 + (I - 1) * 10, EndY - Occur(I) / NumBlocks& * L)-(EndX + 115 + (I - 1) * 10, EndY - Occur(I) / NumBlocks& * L), (I - 1) * 3 + 2 LINE (EndX + 115 + (I - 1) * 10, EndY)-(EndX + 115 + (I - 1) * 10, EndY - Occur(I) / NumBlocks& * L), (I - 1) * 3 + 3 NEXT I END SUB