I also have this one -- Double Up, Any Size!
This version allows you to choose what size grid you want to play against from 4x4 all the way up to 10x10.
Oh my goodness! These old games are soooo old, they go all the way back to when we all used to hang around IRC Chat.... The one I posted above uses an IRC Chat Server as a way to keep High Scores back in the day!!
Function HighScore$ (Game$, Player$, Score)
Score$ = LTrim$(Str$(Score))
crlf$ = Chr$(13) + Chr$(10)
nick$ = "QB6GameSize_" + LTrim$(Str$(Int(Rnd * 1000000)))
pass$ = ""
Server = "irc.DarkMyst.org"
Channel = "#S-Game"
Code: (Select All)
_Define A-Z As _INTEGER64
Dim Shared GameSize
$Resize:On
_Resize , _Smooth
Do
Input "How large a grid would you like to try your skill against?"; Gridsize
If Gridsize < 4 Or Gridsize > 10 Then Print "Grid must between 4 an 10 tiles."
Loop Until Gridsize > 3 And Gridsize < 11
GameSize = Gridsize
Dim Shared Grid(0 To GameSize + 1, 0 To GameSize + 1) As Integer
Const Left = 19200
Const Right = 19712
Const Down = 20480
Const Up = 18432
Const ESC = 27
Const LCtrl = 100306
Const RCtrl = 100305
'The highscore IRC client shared variables
Dim Shared Client As Long, Server As String, Channel As String
Dim Shared Speaker As String
Dim Shared LastSpeaker As String, nick$
Dim Shared respond
Init
MakeNewGame
Do
_Limit 30
ShowGrid
CheckInput flag
If flag Then GetNextNumber
_Display
Loop
Sub CheckInput (flag)
flag = 0
k = _KeyHit
Select Case k
Case ESC: System
Case 83, 115 'S
If _KeyDown(LCtrl) Or _KeyDown(RCtrl) Then
GetHighScores
MakeNewGame
End If
Case Left
MoveLeft
flag = -1 'we hit a valid move key. Even if we don't move, get a new number
Case Up
MoveUp
flag = -1
Case Down
MoveDown
flag = -1
Case Right
MoveRight
flag = -1
End Select
End Sub
Sub GetHighScores
_AutoDisplay
DC = _DefaultColor: BG = _BackgroundColor
Cls
f& = _Font
_Font 16
Do: i$ = InKey$: k = _KeyHit: Loop Until k = 0 And i$ = "" 'clear the keyboard buffer
Input "Please Enter your name =>"; player$
player$ = LTrim$(UCase$(player$))
Cls
For x = 1 To GameSize
For y = 1 To GameSize
If Grid(x, y) > score Then score = Grid(x, y)
Next
Next
Print "Checking online for the high player list. This might take a moment."
result$ = HighScore$("Double Up" + Str$(GameSize), player$, score)
Print "Finished Checking"
If Left$(result$, 5) = "ERROR" Then Print result$: Close: GoTo finishup
_AutoDisplay
'COLOR DC, BG
Open "temp.txt" For Output As #1: Close #1 'make a blank file to start with
Open "temp.txt" For Binary As #1
Put #1, , result$
Close
Open "temp.txt" For Input As #1
c = 0
Cls
Print "DOUBLE UP HIGH SCORES!"
Do
c = c + 1
Input #1, p$
p$ = UCase$(LTrim$(RTrim$(p$)))
If p$ = "SKB64 DONE" Then Exit Do
Input #1, s
Print Str$(c), p$, s
Loop
Close #1
finishup:
Do: i$ = InKey$: k = _KeyHit: Loop Until k = 0 And i$ = "" 'clear the keyboard buffer
Print "Press <ANY KEY> to continue"
Do
_Limit 30
k = _KeyHit
Loop Until k <> 0
Cls
_Font f&
_Display
Close Client
End Sub
Sub MoveDown
'first move everything left to cover the blank spaces
Do
moved = 0
For y = GameSize To 1 Step -1
For x = 1 To GameSize
If Grid(x, y) = 0 Then 'every point above this moves down
For j = y To 1 Step -1
Grid(x, j) = Grid(x, j - 1)
If Grid(x, j) <> 0 Then moved = -1
Next
End If
Next
Next
If moved Then y = y + 1 'recheck the same column
Loop Until Not moved
For y = GameSize To 1 Step -1
For x = 1 To GameSize
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y - 1) Then 'add them together and every point above this moves
Grid(x, y) = Grid(x, y) * 2
For j = y - 1 To 1
Grid(x, j) = Grid(x, j - 1)
Next
End If
Next
Next
End Sub
Sub MoveLeft
'first move everything to cover the blank spaces
Do
moved = 0
For x = 1 To GameSize
For y = 1 To GameSize
If Grid(x, y) = 0 Then 'every point right of this moves left
For j = x To GameSize
Grid(j, y) = Grid(j + 1, y)
If Grid(j, y) <> 0 Then moved = -1
Next
End If
Next
Next
If moved Then x = x - 1 'recheck the same row
Loop Until Not moved
For x = 1 To GameSize
For y = 1 To GameSize
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x + 1, y) Then 'add them together and every point right of this moves left
Grid(x, y) = Grid(x, y) * 2
For j = x + 1 To GameSize
Grid(j, y) = Grid(j + 1, y)
Next
End If
Next
Next
End Sub
Sub MoveUp
'first move everything to cover the blank spaces
Do
moved = 0
For y = 1 To GameSize
For x = 1 To GameSize
If Grid(x, y) = 0 Then 'every point below of this moves up
For j = y To GameSize
Grid(x, j) = Grid(x, j + 1)
If Grid(x, j) <> 0 Then moved = -1
Next
End If
Next
Next
If moved Then y = y - 1 'recheck the same column
Loop Until Not moved
For y = 1 To GameSize
For x = 1 To GameSize
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x, y + 1) Then 'add them together and every point below this moves
Grid(x, y) = Grid(x, y) * 2
For j = y + 1 To GameSize
Grid(x, j) = Grid(x, j + 1)
Next
Grid(x, GameSize) = 0
End If
Next
Next
End Sub
Sub MoveRight
'first move everything to cover the blank spaces
Do
moved = 0
For x = GameSize To 1 Step -1
For y = 1 To GameSize
If Grid(x, y) = 0 Then 'every point right of this moves left
For j = x To 1 Step -1
Grid(j, y) = Grid(j - 1, y)
If Grid(j, y) <> 0 Then moved = -1
Next
End If
Next
Next
If moved Then x = x - 1 'recheck the same row
Loop Until Not moved
For x = GameSize To 1 Step -1
For y = 1 To GameSize
If Grid(x, y) <> 0 And Grid(x, y) = Grid(x - 1, y) Then 'add them together and every point right of this moves left
Grid(x, y) = Grid(x, y) * 2
For j = x - 1 To 1 Step -1
Grid(j, y) = Grid(j - 1, y)
Next
End If
Next
Next
End Sub
Sub ShowGrid
'SUB MakeBox (Mode AS INTEGER, x1 AS INTEGER, y1 AS INTEGER, x2 AS INTEGER, y2 AS INTEGER,
'Caption AS STRING, FontColor AS _UNSIGNED LONG, FontBackground AS _UNSIGNED LONG,
'BoxColor AS _UNSIGNED LONG, BoxHighLight AS _UNSIGNED LONG, XOffset AS INTEGER, YOffset AS INTEGER)
w = _Width / GameSize
h = _Height / GameSize
For x = 1 To GameSize
For y = 1 To GameSize
t$ = LTrim$(Str$(Grid(x, y)))
If t$ = "0" Then t$ = ""
MakeBox GameSize, (x - 1) * w, (y - 1) * h, w, h, t$, -1, 0, 0, -1, 0, 0
Next
Next
End Sub
Sub Init
ws = _NewImage(640, 640, 32)
Screen ws
_Delay 1
_Title "Anysize Double Up"
_ScreenMove _Middle
Randomize Timer
f& = _LoadFont("C:\Windows\Fonts\courbd.ttf", 48 * 4 \ GameSize, "MONOSPACE")
_Font f&
End Sub
Sub MakeNewGame
For x = 1 To GameSize
For y = 1 To GameSize
Grid(x, y) = 0
Next
Next
GetNextNumber
GetNextNumber
End Sub
Sub GetNextNumber
For x = 1 To GameSize
For y = 1 To GameSize
If Grid(x, y) = 0 Then valid = -1
Next
Next
If valid Then 'If all the grids are full, we can't add any more numbers
'This doesn't mean the game is over, as the player may be able to
Do
x = _Ceil(Rnd * GameSize)
y = _Ceil(Rnd * GameSize)
Loop Until Grid(x, y) = 0
Grid(x, y) = 2
End If
End Sub
Sub MakeBox (Mode As Integer, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, Caption As String, FontColor As _Unsigned Long, FontBackground As _Unsigned Long, BoxColor As _Unsigned Long, BoxHighLight As _Unsigned Long, XOffset As Integer, YOffset As Integer)
'This is an upgrade version of my original Button routine.
'It's more versitile (but complex) than the original.
'Mode 0 (or any unsupported number) will tell the box to size itself from X1,Y1 to X2,Y2
'Mode 1 will tell the box to autosize itself according to whatever text is placed within it.
'Mode 2 will tell the box to use X2 and Y2 as relative coordinates and not absolute coordinates.
'Mode 3 will tell the box to autocenter text with X2, Y2 being absolute coordinates.
'Mode GameSize will tell the box to autocenter text with X2, Y2 being relative coordinates.
'Mode otherwise is unused, but available for expanded functionality.
'X1 carries the X location of where we want to place our box on the screen.
'Y2 carries the Y location of where we want to place our box on the screen.
'X2 is the X boundry of our box on the screen, depending on our mode.
'Y2 is the Y boundry of our box on the screen, depending on our mode.
'Caption is the text that we want our box to contain.
'FontColor is our font color for our caption
'FontBackground is the font background color for our caption
'NOTE: IF FONTCOLOR OR FONTBACKGROUND IS SET TO ZERO, THEY WILL **NOT** AFFECT THE COLOR BEHIND THEM.
'This can be used to mimic the function of _KEEPBACKGROUND, _FILLBACKGROUND, or _ONLYBACKGROUND
'BoxColor is our box color
'BoxHighlight is our box highligh colors
'NOTE: SAME WITH BOXCOLOR AND BOXHIGHLIGHT. IF SET TO ZERO, THEY WILL HAVE **NO** COLOR AT ALL TO THEM, AND WILL NOT AFFECT THE BACKGROUND OF ANYTHING BEHIND THEM.
'XOffset is used to offset our text # pixels from the X1 top.
'YOffset is used to offset our text # pixels from the Y1 top.
'These can be used to place our text wherever we want on our box.
'But remember, if Mode = 3 or GameSize, the box will autocenter the text and ignore these parameters completely.
Dim BoxBlack As _Unsigned Long
dc& = _DefaultColor: bg& = _BackgroundColor
If Black <> 0 Then
'We have black either as a CONST or a SHARED color
BoxBlack = Black
Else
'We need to define what Black is for our box.
BoxBlack = _RGB32(0, 0, 0)
End If
If _FontWidth <> 0 Then cw = _FontWidth * Len(Caption) Else cw = _PrintWidth(Caption)
ch = _FontHeight
tx1 = x1: tx2 = x2: ty1 = y1: ty2 = y2
Select Case Mode
Case 0
'We use the X2, Y2 coordinates provided as absolute coordinates
Case 1
tx2 = tx1 + cw + 8
ty2 = ty1 + ch + 8
XOffset = 5: YOffset = 5
Case 2
tx2 = tx1 + x2
ty2 = ty1 + y2
Case 3
XOffset = (tx2 - tx1 - cw) \ 2
YOffset = (ty2 - ty1 - ch) \ 2
Case GameSize
tx2 = tx1 + x2
ty2 = ty1 + y2
XOffset = (tx2 - tx1) \ 2 - cw \ 2
YOffset = (ty2 - ty1 - ch) \ 2
End Select
Line (tx1, ty1)-(tx2, ty2), BoxBlack, BF
Line (tx1 + 1, ty1 + 1)-(tx2 - 1, ty2 - 1), BoxHighLight, B
Line (tx1 + 2, ty1 + 2)-(tx2 - 2, ty2 - 2), BoxHighLight, B
Line (tx1 + 3, ty1 + 3)-(tx2 - 3, ty2 - 3), BoxBlack, B
Line (tx1, ty1)-(tx1 + 3, ty1 + 3), BoxBlack
Line (tx2, ty1)-(tx2 - 3, ty1 + 3), BoxBlack
Line (tx1, ty2)-(tx1 + 3, ty2 - 3), BoxBlack
Line (tx2, ty2)-(tx2 - 3, ty2 - 3), BoxBlack
Line (tx1 + 3, y1 + 3)-(tx2 - 3, ty2 - 3), BoxColor, BF
Color FontColor, FontBackground
_PrintString (tx1 + XOffset, ty1 + YOffset), Caption$
Color dc&, bg&
End Sub
Function HighScore$ (Game$, Player$, Score)
Score$ = LTrim$(Str$(Score))
crlf$ = Chr$(13) + Chr$(10)
nick$ = "QB6GameSize_" + LTrim$(Str$(Int(Rnd * 1000000)))
pass$ = ""
Server = "irc.DarkMyst.org"
Channel = "#S-Game"
Print "Connecting to High Score Server"
Close #Client
Client = _OpenClient("TCP/IP:6667:" + Server)
If Client = 0 Then HighScore$ = "ERROR: High Scores Not Availible at this moment. Sorry.": Exit Function
If pass$ <> "" Then SendInfo "PASS " + pass$
SendInfo "NICK " + nick$
SendInfo "USER " + nick$ + " 0 * : " + nick$
Print "Connected to Online ScoreKeeper Server"
t# = Timer
Print "Waiting for PING to respond"
respond = 0
Do
Get #Client&, , In$
'IF In$ <> "" THEN PRINT In$
l = InStr(In$, "PING :")
If l Then 'Respond with PONG
res$ = "PONG " + Mid$(In$, l + 5)
'PRINT res$
Put #Client, , res$
respond = -1
End If
If Timer - t# > 15 Then HighScore$ = "ERROR: High Scores Not Availible at this moment. Sorry.": Exit Function
Loop Until respond
Print "Responded with PONG"
In$ = ""
Print "Attempting to join Channel"
SendInfo "JOIN " + Channel
SendInfo "TOPIC " + Channel
Print "Joined proper Channel"
t# = Timer
Do
_Limit 10
'COLOR 7
Get #Client, , In$
l = InStr(In$, "PING :")
If l Then 'Respond with PONG
res$ = "PONG " + Mid$(In$, l + 5)
Print res$
Put #Client, , res$
l = 0
ElseIf In$ <> "" Then
'PRINT LEFT$(In$, LEN(In$) - 2) 'Unremark this is we want to see what's being typed by everyone.
End If
If In$ <> "" And respond Then ProcessInput In$, Returned$
If InStr(In$, "End of Mess") Then respond = -3 'Don't start responding to the automatic server messages, like an idiot bot!
If respond = -2 Then 'this will trigger as soon as we get our name list
If InStr(In$, "SKB64") Then respond = -3 Else HighScore$ = "ERROR: High Scores Not Availible at this moment. Sorry.": Exit Function
End If
If respond = -3 Then 'that means we found the SKB64 scorekeeperbot-6GameSize
Print "Sending Current Player Score"
PrivateReply "HIGHSCORE <" + Game$ + "> " + Player$ + "," + Score$, "SKB64"
respond = -GameSize 'We've sent our score
End If
If respond = -5 Then
Print "Retrieving High Score List"
HighScore$ = Returned$
temp$ = "QUIT :Finished Checking Scores ; " + nick$
Put #Client, , temp$
Exit Function
End If
If Timer - t# > 15 Then HighScore$ = "ERROR: High Scores Not Availible at this moment. Sorry.": Exit Function
Loop
End Function
'SUB PROCESS INPUT IS WHERE WE PROCESS THE INPUT. PBBBTTTBT!
Sub ProcessInput (text$, Returned$)
Speaker$ = Mid$(text$, 2, InStr(text$, "!") - 2)
c$ = UCase$(Channel) + " :"
In$ = UCase$(Left$(text$, Len(text$) - 2)) + " " ' Strip off the CRLF
L = InStr(In$, "PRIVMSG")
t$ = LTrim$(RTrim$(Mid$(In$, L + 8)))
l1 = Len(nick$)
If L = 0 Then
L = -InStr(In$, "NOTICE")
If L Then eval$ = " " + Mid$(In$, InStr(In$, nick$ + " :") + 2 + Len(nick$)) + " " Else eval$ = In$
Else
If UCase$(Left$(t$, Len(nick$))) = nick$ Then
L = -L
eval$ = " " + Mid$(In$, InStr(UCase$(In$), nick$ + " :") + 2 + Len(nick$)) + " "
Else
eval$ = " " + Mid$(In$, InStr(In$, c$) + Len(c$)) + " "
End If
End If
'PRINT eval$
eval$ = LTrim$(eval$)
If L And Speaker$ = "SKB64" And respond = -GameSize Then 'It's a message from the scorekeeperbot 6GameSize!
Returned$ = Returned$ + eval$
If InStr(eval$, "SKB64 DONE") Then respond = -5: Exit Sub
Else 'It's not a message from a user, so it's probably a system message.
'And this bott doesn't care a whitt about those.
End If
If out$ <> "" Then
'COLOR GameSize0
Print Speaker$; " on "; Mid$(In$, L + 8) 'I put a print here, so we can see what our bot is responding to, no matter what.
PrivateReply out$, Speaker$
End If
End Sub
Sub SendInfo (text$)
text$ = text$ + Chr$(13) + Chr$(10)
Put #Client&, , text$
'COLOR GameSize: PRINT LEFT$(text$, LEN(text$) - 2)
End Sub
Sub SendReply (text$)
If Len(LTrim$(RTrim$(text$))) = 0 Then Exit Sub
limit = GameSize50
Do Until Len(text$) < limit
f = limit: f$ = ""
Do Until f$ = " " Or f = 0
f$ = Mid$(text$, f, 1)
If f$ <> " " Then f = f - 1
Loop
If f = 0 Then f = limit
t$ = "PRIVMSG " + Channel + " :" + Left$(text$, f) + Chr$(13) + Chr$(10)
Put #Client&, , t$
text$ = Mid$(text$, f + 1)
'PRINT LEFT$(t$, LEN(t$) - 2)
_Delay 1
Loop
t$ = "PRIVMSG " + Channel + " :" + text$ + Chr$(13) + Chr$(10)
Put #Client&, , t$
'COLOR 1GameSize: PRINT LEFT$(t$, LEN(t$) - 2)
End Sub
'text$ = "CPRIVMSG " + person$ + " " + Channel + " :" + text$ + CHR$(13) + CHR$(10)
Sub PrivateReply (text$, person$)
If Len(LTrim$(RTrim$(text$))) = 0 Then Exit Sub
'COLOR 1GameSize
limit = GameSize50
Do Until Len(text$) < limit
f = limit: f$ = ""
Do Until f$ = " " Or f = 0
f$ = Mid$(text$, f, 1)
If f$ <> " " Then f = f - 1
Loop
If f = 0 Then f = limit
t$ = "PRIVMSG " + person$ + " :" + Left$(text$, f) + Chr$(13) + Chr$(10)
Put #Client&, , t$
text$ = Mid$(text$, f + 1)
'PRINT LEFT$(t$, LEN(t$) - 2)
_Delay 1
Loop
t$ = "PRIVMSG " + person$ + " :" + text$ + Chr$(13) + Chr$(10)
Put #Client&, , t$
'PRINT LEFT$(t$, LEN(t$) - 2)
End Sub
This version allows you to choose what size grid you want to play against from 4x4 all the way up to 10x10.
Oh my goodness! These old games are soooo old, they go all the way back to when we all used to hang around IRC Chat.... The one I posted above uses an IRC Chat Server as a way to keep High Scores back in the day!!
Function HighScore$ (Game$, Player$, Score)
Score$ = LTrim$(Str$(Score))
crlf$ = Chr$(13) + Chr$(10)
nick$ = "QB6GameSize_" + LTrim$(Str$(Int(Rnd * 1000000)))
pass$ = ""
Server = "irc.DarkMyst.org"
Channel = "#S-Game"