2048: Difference between revisions

=={{header|BASIC}}==

{{works with|QBasic}}

El código es de MichD (https://github.com/michd/2048-qbasic)

Yo solo lo transcribo.

<lang qbasic>

SCREEN 13

PALETTE 1, pColor(35, 33, 31)

PALETTE 2, pColor(46, 46, 51)

PALETTE 3, pColor(59, 56, 50)

PALETTE 4, pColor(61, 44, 30)

PALETTE 5, pColor(61, 37, 25)

PALETTE 6, pColor(62, 31, 24)

PALETTE 7, pColor(62, 24, 15)

PALETTE 8, pColor(59, 52, 29)

PALETTE 9, pColor(59, 51, 24)

PALETTE 10, pColor(59, 50, 20)

PALETTE 11, pColor(59, 49, 16)

PALETTE 12, pColor(59, 49, 12)

PALETTE 13, pColor(15, 15, 13)

PALETTE 14, pColor(23, 22, 20)

DIM SHARED gDebug

DIM SHARED gOriginX

DIM SHARED gOriginY

DIM SHARED gTextOriginX

DIM SHARED gTextOriginY

DIM SHARED gSquareSide

DIM SHARED gGridSize

gGridSize = 4 ' grid size (4 -> 4x4)

DIM SHARED gGrid(gGridSize, gGridSize)

DIM SHARED gScore

' Don't touch these numbers, seriously

gOriginX = 75 'pixel X of top left of grid

gOriginY = 12 'pixel Y of top right of grid

gTextOriginX = 11

gTextOriginY = 3

gSquareSide = 38 'width/height of block in pixels

'set up all the things!

gDebug = 0

RANDOMIZE TIMER

CLS

start:

initGrid

initGraphicGrid

renderGrid

updateScore

gScore = 0

LOCATE 23, 1

PRINT "Move with arrow keys. (R)estart, (Q)uit"

' keyboard input loop

DO

DO

k$ = INKEY$

LOOP UNTIL k$ <> ""

SELECT CASE k$

CASE CHR$(0) + CHR$(72) 'up

processMove ("u")

CASE CHR$(0) + CHR$(80) 'down

processMove ("d")

CASE CHR$(0) + CHR$(77) 'right

processMove ("r")

CASE CHR$(0) + CHR$(75) 'left

processMove ("l")

CASE CHR$(27) 'escape

GOTO programEnd

CASE "q"

GOTO programEnd

CASE "Q"

GOTO programEnd

CASE "r"

GOTO start

CASE "R"

GOTO start

END SELECT

LOOP

programEnd:

SUB addblock

DIM emptyCells(gGridSize * gGridSize, 2)

emptyCellCount = 0

FOR x = 0 TO gGridSize - 1

FOR y = 0 TO gGridSize - 1

IF gGrid(x, y) = 0 THEN

emptyCells(emptyCellCount, 0) = x

emptyCells(emptyCellCount, 1) = y

emptyCellCount = emptyCellCount + 1

END IF

NEXT y

NEXT x

IF emptyCellCount > 0 THEN

index = INT(RND * emptyCellCount)

num = CINT(RND + 1) * 2

gGrid(emptyCells(index, 0), emptyCells(index, 1)) = num

END IF

END SUB

SUB drawNumber (num, xPos, yPos)

SELECT CASE num

CASE 0: c = 16

CASE 2: c = 2

CASE 4: c = 3

CASE 8: c = 4

CASE 16: c = 5

CASE 32: c = 6

CASE 64: c = 7

CASE 128: c = 8

CASE 256: c = 9

CASE 512: c = 10

CASE 1024: c = 11

CASE 2048: c = 12

CASE 4096: c = 13

CASE 8192: c = 13

CASE ELSE: c = 13

END SELECT

x = xPos * (gSquareSide + 2) + gOriginX + 1

y = yPos * (gSquareSide + 2) + gOriginY + 1

LINE (x + 1, y + 1)-(x + gSquareSide - 1, y + gSquareSide - 1), c, BF

IF num > 0 THEN

LOCATE gTextOriginY + 1 + (yPos * 5), gTextOriginX + (xPos * 5)

PRINT " "

LOCATE gTextOriginY + 2 + (yPos * 5), gTextOriginX + (xPos * 5)

PRINT pad$(num)

LOCATE gTextOriginY + 3 + (yPos * 5), gTextOriginX + (xPos * 5)

'PRINT " "

END IF

END SUB

FUNCTION getAdjacentCell (x, y, d AS STRING)

IF (d = "l" AND x = 0) OR (d = "r" AND x = gGridSize - 1) OR (d = "u" AND y = 0) OR (d = "d" AND y = gGridSize - 1) THEN

getAdjacentCell = -1

ELSE

SELECT CASE d

CASE "l": getAdjacentCell = gGrid(x - 1, y)

CASE "r": getAdjacentCell = gGrid(x + 1, y)

CASE "u": getAdjacentCell = gGrid(x, y - 1)

CASE "d": getAdjacentCell = gGrid(x, y + 1)

END SELECT

END IF

END FUNCTION

'Draws the outside grid (doesn't render tiles)

SUB initGraphicGrid

gridSide = (gSquareSide + 2) * gGridSize

LINE (gOriginX, gOriginY)-(gOriginX + gridSide, gOriginY + gridSide), 14, BF 'outer square, 3 thick

LINE (gOriginX, gOriginY)-(gOriginX + gridSide, gOriginY + gridSide), 1, B 'outer square, 3 thick

LINE (gOriginX - 1, gOriginY - 1)-(gOriginX + gridSide + 1, gOriginY + gridSide + 1), 1, B

LINE (gOriginX - 2, gOriginY - 2)-(gOriginX + gridSide + 2, gOriginY + gridSide + 2), 1, B

FOR x = gOriginX + gSquareSide + 2 TO gOriginX + (gSquareSide + 2) * gGridSize STEP gSquareSide + 2 ' horizontal lines

LINE (x, gOriginY)-(x, gOriginY + gridSide), 1

NEXT x

FOR y = gOriginY + gSquareSide + 2 TO gOriginY + (gSquareSide + 2) * gGridSize STEP gSquareSide + 2 ' vertical lines

LINE (gOriginX, y)-(gOriginX + gridSide, y), 1

NEXT y

END SUB

'Init the (data) grid with 0s

SUB initGrid

FOR x = 0 TO 3

FOR y = 0 TO 3

gGrid(x, y) = 0

NEXT y

NEXT x

addblock

addblock

END SUB

SUB moveBlock (sourceX, sourceY, targetX, targetY, merge)

IF sourceX < 0 OR sourceX >= gGridSize OR sourceY < 0 OR sourceY >= gGridSize AND gDebug = 1 THEN

LOCATE 0, 0

PRINT "moveBlock: source coords out of bounds"

END IF

IF targetX < 0 OR targetX >= gGridSize OR targetY < 0 OR targetY >= gGridSize AND gDebug = 1 THEN

LOCATE 0, 0

PRINT "moveBlock: source coords out of bounds"

END IF

sourceSquareValue = gGrid(sourceX, sourceY)

targetSquareValue = gGrid(targetX, targetY)

IF merge = 1 THEN

IF sourceSquareValue = targetSquareValue THEN

gGrid(sourceX, sourceY) = 0

gGrid(targetX, targetY) = targetSquareValue * 2

gScore = gScore + targetSquareValue * 2 ' Points!

ELSEIF gDebug = 1 THEN

LOCATE 0, 0

PRINT "moveBlock: Attempted to merge unequal sqs"

END IF

ELSE

IF targetSquareValue = 0 THEN

gGrid(sourceX, sourceY) = 0

gGrid(targetX, targetY) = sourceSquareValue

ELSEIF gDebug = 1 THEN

LOCATE 0, 0

PRINT "moveBlock: Attempted to move to non-empty block"

END IF

END IF

END SUB

FUNCTION pad$ (num)

strNum$ = LTRIM$(STR$(num))

SELECT CASE LEN(strNum$)

CASE 1: pad = " " + strNum$ + " "

CASE 2: pad = " " + strNum$ + " "

CASE 3: pad = " " + strNum$

CASE 4: pad = strNum$

END SELECT

END FUNCTION

FUNCTION pColor (r, g, b)

pColor = (r + g * 256 + b * 65536)

END FUNCTION

SUB processMove (dir AS STRING)

' dir can be 'l', 'r', 'u', or 'd'

hasMoved = 0

IF dir = "l" THEN

FOR y = 0 TO gGridSize - 1

wasMerge = 0

FOR x = 0 TO gGridSize - 1

GOSUB processBlock

NEXT x

NEXT y

ELSEIF dir = "r" THEN

FOR y = 0 TO gGridSize - 1

wasMerge = 0

FOR x = gGridSize - 1 TO 0 STEP -1

GOSUB processBlock

NEXT x

NEXT y

ELSEIF dir = "u" THEN

FOR x = 0 TO gGridSize - 1

wasMerge = 0

FOR y = 0 TO gGridSize - 1

GOSUB processBlock

NEXT y

NEXT x

ELSEIF dir = "d" THEN

FOR x = 0 TO gGridSize - 1

wasMerge = 0

FOR y = gGridSize - 1 TO 0 STEP -1

GOSUB processBlock

NEXT y

NEXT x

END IF

GOTO processMoveEnd

moveToObstacle:

curX = x

curY = y

DO WHILE getAdjacentCell(curX, curY, dir) = 0

SELECT CASE dir

CASE "l": curX = curX - 1

CASE "r": curX = curX + 1

CASE "u": curY = curY - 1

CASE "d": curY = curY + 1

END SELECT

LOOP

RETURN

processBlock:

merge = 0

IF gGrid(x, y) <> 0 THEN ' have block

GOSUB moveToObstacle ' figure out where it can be moved to

IF getAdjacentCell(curX, curY, dir) = gGrid(x, y) AND wasMerge = 0 THEN ' obstacle can be merged with

merge = 1

wasMerge = 1

ELSE

wasMerge = 0

END IF

IF curX <> x OR curY <> y OR merge = 1 THEN

mergeDirX = 0

mergeDirY = 0

IF merge = 1 THEN

SELECT CASE dir

CASE "l": mergeDirX = -1

CASE "r": mergeDirX = 1

CASE "u": mergeDirY = -1

CASE "d": mergeDirY = 1

END SELECT

END IF

CALL moveBlock(x, y, curX + mergeDirX, curY + mergeDirY, merge) ' move to before obstacle or merge

hasMoved = 1

END IF

END IF

RETURN

processMoveEnd:

IF hasMoved = 1 THEN addblock

renderGrid

updateScore

END SUB

SUB renderGrid

FOR x = 0 TO gGridSize - 1

FOR y = 0 TO gGridSize - 1

CALL drawNumber(gGrid(x, y), x, y)

NEXT y

NEXT x

END SUB

SUB updateScore

LOCATE 1, 10

PRINT "Score:" + STR$(gScore)

END SUB

</lang>