The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 

 Return to Index  

Pentris

November 12 2008 at 4:27 PM
Tim  (Login T3sl4)
R


Response to Tetris

 
Here's the code for Pentris. Almost everything is the same up to constants and the additional patterns. You can also set whatever size field you like. Hooray for constants!

You'll notice Pentris is a lot harder. Five blocks gets you a lot more pieces (18 vs. 7) and they're a lot uglier, so they fit a lot worse. Hmm, maybe I should put in n-ominoes where n = 1 to 5, those would fill the gaps nicely...

Tim


' Tetris, but with pentominoes. Pentris!

DEFINT A-Z

CONST GridWidth = 8, GridHeight = 16
CONST Pentominoes = 18, InitShapeHeight = 3, MaxShapeWidth = 5
CONST MaxShapeHeight = MaxShapeWidth
CONST Block = 12, Border = 2, GridColr = 7, ActColr = 9
CONST FallDelay = .5
CONST FALSE = 0, TRUE = NOT FALSE

DIM Grid(GridWidth - 1, GridHeight - 1)
DIM ActShape(MaxShapeWidth - 1, MaxShapeHeight - 1)
DIM RotShape(MaxShapeWidth - 1, MaxShapeHeight - 1)
DIM Shapes(MaxShapeWidth - 1, InitShapeHeight - 1, Pentominoes - 1)
DIM CompleteRows(MaxShapeHeight - 1)
DIM xShape, yShape, xShSize, yShSize, Moved, Start AS SINGLE
DIM VisPage, ActPage

RANDOMIZE TIMER

VisPage = 0: ActPage = 1
SCREEN 7, , ActPage, VisPage

' Load the shapes from data
FOR i = 0 TO Pentominoes - 1
FOR y = 0 TO InitShapeHeight - 1
FOR x = 0 TO MaxShapeWidth - 1
READ k
IF k = 1 THEN Shapes(x, y, i) = TRUE ELSE Shapes(x, y, i) = FALSE
NEXT
NEXT
NEXT

' Set the first piece
GOSUB InitShape

' Main loop
DO
k$ = INKEY$
SELECT CASE k$
CASE CHR$(0) + "K" 'Left
GOSUB MoveLeft
CASE CHR$(0) + "M" 'Right
GOSUB MoveRight
CASE CHR$(0) + "P" 'Down
GOSUB MoveDown
Start = TIMER + FallDelay
CASE " " 'Rotate right
GOSUB Rotate
Start = TIMER + FallDelay / 2
CASE CHR$(27) 'Quit
EXIT DO
END SELECT
IF TIMER > Start THEN GOSUB MoveDown: Start = TIMER + FallDelay
IF Moved THEN GOSUB RefreshScreen: Moved = FALSE
LOOP

END


'
' -=-=- Subroutines -=-=-
'
' Note: NOT reentrant. All RETURN, so always call with GOSUB.
'


' Initializes the active piece, placing it at the top, center.
InitShape:
' Select a random piece (notice even distribution for all Pentominoes)
i = FIX(RND * Pentominoes)
' Copy the piece into active, checking dimensions
xShSize = 0: yShSize = 0
FOR y = 0 TO MaxShapeWidth - 1
FOR x = 0 TO MaxShapeWidth - 1
IF y >= InitShapeHeight THEN ActShape(x, y) = FALSE ELSE ActShape(x, y) = Shapes(x, y, i)
IF ActShape(x, y) AND x + 1 > xShSize THEN xShSize = x + 1
IF ActShape(x, y) AND y + 1 > yShSize THEN yShSize = y + 1
NEXT
NEXT
xShape = GridWidth \ 2 - xShSize \ 2: yShape = 0
Moved = TRUE: Start = TIMER + FallDelay
RETURN


' Moves the active piece left, if possible.
MoveLeft:
' Can't move any farther left?
IF xShape <= 0 THEN RETURN
' Test the move and see if it hits something
xShape = xShape - 1
GOSUB TestShape
IF Test THEN
xShape = xShape + 1
ELSE
Moved = TRUE
SOUND 1000, .1
END IF
RETURN


' Moves the active piece right, if possible.
MoveRight:
' Can't move any farther right?
IF xShape + xShSize >= GridWidth THEN RETURN
' Test the move and see if it hits something
xShape = xShape + 1
GOSUB TestShape
IF Test THEN
xShape = xShape - 1
ELSE
Moved = TRUE
SOUND 1000, .1
END IF
RETURN


' Moves the active piece down, if possible. If not, the piece is placed
' on the grid and the grid checked for complete rows.
MoveDown:
' Can't move any farther down?
IF yShape + yShSize >= GridHeight THEN GOSUB PlaceShape: RETURN
' Test the move and see if it hits something
yShape = yShape + 1
GOSUB TestShape
IF Test AND yShape = 1 THEN
LOCATE 1, 20: PRINT "You lost."
SOUND 600, 3
SOUND 400, 10
END
END IF
IF Test THEN
yShape = yShape - 1
GOSUB PlaceShape
ELSE
Moved = TRUE
SOUND 1000, .1
END IF
RETURN


' Transfers the active shape to the grid, checks for complete rows
' and all that, then calls InitShape.
PlaceShape:
' Place the shape on the grid
FOR y = 0 TO yShSize - 1
FOR x = 0 TO xShSize - 1
Grid(x + xShape, y + yShape) = Grid(x + xShape, y + yShape) OR ActShape(x, y)
NEXT
NEXT
SOUND 1000, 1
' Check all involved rows if they are complete
FOR i = 0 TO MaxShapeHeight - 1
CompleteRows(i) = -1
NEXT
i = 0
FOR y = 0 TO yShSize - 1
FOR x = 0 TO GridWidth - 1
IF Grid(x, y + yShape) THEN CompleteRows(i) = CompleteRows(i) + 1
NEXT
IF CompleteRows(i) = GridWidth - 1 THEN CompleteRows(i) = y + yShape: i = i + 1 ELSE CompleteRows(i) = -1
NEXT
' Check the list of complete rows.
' Bump down everything above each row.
FOR j = 0 TO i - 1
FOR y = CompleteRows(j) TO 0 STEP -1
FOR x = 0 TO GridWidth - 1
IF y = 0 THEN Grid(x, y) = FALSE ELSE Grid(x, y) = Grid(x, y - 1)
NEXT
NEXT
SOUND 1500 * j, 2
NEXT
GOSUB InitShape
RETURN


' Rotates the active piece clockwise 90 degrees.
' Updates xShSize and yShSize.
' If overlap is detected, the rotation is undone.
Rotate:
' Make a rotated and translated copy
SWAP xShSize, yShSize
FOR y = 0 TO MaxShapeHeight - 1
FOR x = 0 TO MaxShapeWidth - 1
xR = y: yR = xShSize - 1 - x
IF xR >= 0 AND yR >= 0 AND xR < MaxShapeWidth AND yR < MaxShapeWidth THEN
RotShape(x, y) = ActShape(xR, yR)
ELSE
RotShape(x, y) = FALSE
END IF
NEXT
NEXT
IF xShape + xShSize >= GridWidth THEN xShape = GridWidth - xShSize
IF yShape + yShSize >= GridHeight THEN yShape = GridHeight - yShSize
' Test the rotated piece to see if it's okay
Test = 0
FOR y = 0 TO yShSize - 1
FOR x = 0 TO xShSize - 1
IF Grid(x + xShape, y + yShape) AND RotShape(x, y) THEN Test = TRUE: EXIT FOR
NEXT
IF Test THEN EXIT FOR
NEXT
IF Test THEN
' Do nothing, cannot rotate
SWAP xShSize, yShSize
SOUND 1000, .1
ELSE
' Rotate okay, copy it back
FOR y = 0 TO MaxShapeHeight - 1
FOR x = 0 TO MaxShapeWidth - 1
ActShape(x, y) = RotShape(x, y)
NEXT
NEXT
Moved = TRUE
SOUND 250, 1
END IF
RETURN


' Tests the current shape state against the grid to see if anything is
' overlapping. Returns Test true if overlap is detected.
TestShape:
Test = FALSE
FOR y = 0 TO yShSize - 1
FOR x = 0 TO xShSize - 1
IF Grid(x + xShape, y + yShape) AND ActShape(x, y) THEN Test = TRUE: RETURN
NEXT
NEXT
RETURN


' Refreshes the entire screen.
RefreshScreen:
LINE (0, 0)-(GridWidth * Block, GridHeight * Block), 0, BF
FOR x = 0 TO GridWidth - 1
FOR y = 0 TO GridHeight - 1
xScr = x * Block: yScr = y * Block
IF Grid(x, y) THEN LINE (xScr, yScr)-(xScr + Block - Border, yScr + Block - Border), GridColr, BF
NEXT
NEXT
FOR y = 0 TO MaxShapeHeight - 1
FOR x = 0 TO MaxShapeWidth - 1
xScr = (x + xShape) * Block: yScr = (y + yShape) * Block
IF ActShape(x, y) THEN LINE (xScr, yScr)-(xScr + Block - Border, yScr + Block - Border), ActColr, BF
NEXT
NEXT
SWAP ActPage, VisPage
SCREEN 7, , ActPage, VisPage
RETURN


' Pentomino patterns
DATA 1,1,1,1,1
DATA 0,0,0,0,0
DATA 0,0,0,0,0

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

 
 Respond to this message   
Response TitleAuthor and Date
*Lots of fun!TheBOB on Dec 7
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums