Posts: 3,978
Threads: 177
Joined: Apr 2022
Reputation:
220
(10-26-2024, 01:21 PM)Dav Wrote: Interesting, nope I didn’t know that. Is JB =JustBasic?
Yes, no ones posted for over a month, so something was needed over there 
b = b + ...
Posts: 3,978
Threads: 177
Joined: Apr 2022
Reputation:
220
How well can a brainless set of commands do with this game?
2048 - Autoplay
Code: (Select All) DefLng A-Z: Randomize Timer: ReDim Shared B(15) ' 2048 - Autoplay best 7464
Screen _NewImage(405, 405, 32): _ScreenMove 450, 180
_PrintMode _KeepBackground: _Font _LoadFont("arial.ttf", 28)
Color , &HFFBB0033
restart: AddNewCell: AddNewCell
DoLoop: Cls: _Title "High Score:" + Str$(High) + " Score:" + Str$(Score)
For x = 0 To 3: For y = 0 To 3
If B(x + 4 * y) Then pwr = Log(B(x + 4 * y)) / Log(2) Else pwr = 0
bg& = _RGB32(255 - 17 * pwr): bg2& = _RGB32(128 - 12 * pwr)
Line (x * 100 + 4, y * 100 + 4)-Step(100 - 4, 100 - 4), bg&, BF
Line (x * 100 + 5, y * 100 + 5)-Step(100 - 6, 100 - 6), bg2&, B
If B(x + 4 * y) > 0 Then
n$ = _Trim$(Str$(B(x + 4 * y))): u = x * 100: v = y * 100
ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight) / 2
Color &HFF000000: _PrintString (u + ox + 2, v + oy + 2), n$
Color &HFFFFFFFF: _PrintString (u + ox, v + oy), n$
End If
Next: Next: _Display: _Limit 30
eF = 0: xF = 0: yF = 0
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then eF = eF + 1
If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then yF = yF + 1
If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then xF = xF + 1
Next: Next
If (eF = 0 And xF = 0) And yF = 0 Then ' no moves left
If Score > High Then High = Score
Score = 0: ReDim B(15): GoTo restart
End If
ReDim t(15): jm = 0 ' Update Board by arrow keys
If xF > yF Then
If Rnd < .85 Then d = 1 Else d = 2
Else
d = 4
End If
Select Case d
Case 1: jm = 4: ks = 0: ke = 3: kstep = 1: km = 1 ' left
Case 2: jm = 4: ks = 3: ke = 0: kstep = -1: km = 1 'right
Case 3: jm = 1: ks = 0: ke = 3: kstep = 1: km = 4 ' up
Case 4: jm = 1: ks = 3: ke = 0: kstep = -1: km = 4 ' down
End Select
For j = 0 To 3
If jm = 4 Then p = j * jm + ks Else If kstep = 1 Then p = j Else p = 12 + j
For k = ks To ke Step kstep
If B(j * jm + k * km) <> 0 Then
If t(p) = B(j * jm + k * km) Then
t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p)
p = p + kstep * km
ElseIf t(p) = 0 Then '
t(p) = B(j * jm + k * km)
Else
p = p + kstep * km: t(p) = B(j * jm + k * km)
End If
End If
Next k, j
For j = 0 To 15: B(j) = t(j): Next: AddNewCell: GoTo DoLoop
Sub AddNewCell ' == Insert new cell onto board in random unused blank ==
Dim temp(15), x, y, c, i, x1, y1
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
Next x, y
If c > 0 Then
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .9 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4
End If
End Sub
Best score was 7464 in about a half an hour run.
b = b + ...
Posts: 3,978
Threads: 177
Joined: Apr 2022
Reputation:
220
10-27-2024, 10:08 AM
(This post was last modified: 10-27-2024, 10:09 AM by bplus.)
A faster Autoplay almost burnt out my CPU before I put _Limit 4000 in it!
Code: (Select All) ' 2048 - Autoplay 3 Best score faster! b+ 2024-10-27 10544 high
DefLng A-Z: Randomize Timer: ReDim Shared B(15), Score, High
Screen _NewImage(405, 405, 32): _ScreenMove 450, 180
_PrintMode _KeepBackground: _Font _LoadFont("arial.ttf", 28)
Color , &HFFBB0033
restart: AddNewCell: AddNewCell
DoLoop: Cls: _Title "High Score:" + Str$(High) + " Score:" + Str$(Score)
If High = 0 Then DisplayBoard
eF = 0: xF = 0: yF = 0
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then eF = eF + 1
If y < 3 Then If B(y * 4 + x) = B((y + 1) * 4 + x) Then yF = yF + 1
If x < 3 Then If B(y * 4 + x) = B(y * 4 + (x + 1)) Then xF = xF + 1
Next: Next
If (eF = 0 And xF = 0) And yF = 0 Then ' no moves left
If Score > High Then High = Score: DisplayBoard
Score = 0: ReDim B(15): GoTo restart
End If
ReDim t(15): jm = 0 ' Update Board by arrow keys
If xF > yF Then
If Rnd < .85 Then d = 1 Else d = 2
Else
d = 4
End If
Select Case d
Case 1: jm = 4: ks = 0: ke = 3: kstep = 1: km = 1 ' left
Case 2: jm = 4: ks = 3: ke = 0: kstep = -1: km = 1 'right
Case 3: jm = 1: ks = 0: ke = 3: kstep = 1: km = 4 ' up
Case 4: jm = 1: ks = 3: ke = 0: kstep = -1: km = 4 ' down
End Select
For j = 0 To 3
If jm = 4 Then p = j * jm + ks Else If kstep = 1 Then p = j Else p = 12 + j
For k = ks To ke Step kstep
If B(j * jm + k * km) <> 0 Then
If t(p) = B(j * jm + k * km) Then
t(p) = t(p) + B(j * jm + k * km): Score = Score + t(p)
p = p + kstep * km
ElseIf t(p) = 0 Then '
t(p) = B(j * jm + k * km)
Else
p = p + kstep * km: t(p) = B(j * jm + k * km)
End If
End If
Next k, j
For j = 0 To 15: B(j) = t(j): Next: AddNewCell: _Limit 4000: GoTo DoLoop
Sub AddNewCell ' == Insert new cell onto board in random unused blank ==
Dim temp(15), x, y, c, i, x1, y1
For y = 0 To 3: For x = 0 To 3
If B(y * 4 + x) = 0 Then temp(c) = y * 4 + x: c = c + 1
Next x, y
If c > 0 Then
i = Int(Rnd * c): y1 = Int(temp(i) / 4): x1 = temp(i) Mod 4
If Rnd < .9 Then B(4 * y1 + x1) = 2 Else B(4 * y1 + x1) = 4
End If
End Sub
Sub DisplayBoard
For x = 0 To 3: For y = 0 To 3
If B(x + 4 * y) Then pwr = Log(B(x + 4 * y)) / Log(2) Else pwr = 0
bg& = _RGB32(255 - 17 * pwr): bg2& = _RGB32(128 - 12 * pwr)
Line (x * 100 + 4, y * 100 + 4)-Step(100 - 4, 100 - 4), bg&, BF
Line (x * 100 + 5, y * 100 + 5)-Step(100 - 6, 100 - 6), bg2&, B
If B(x + 4 * y) > 0 Then
n$ = _Trim$(Str$(B(x + 4 * y))): u = x * 100: v = y * 100
ox = (100 - _PrintWidth(n$)) / 2: oy = (100 - _FontHeight) / 2
Color &HFF000000: _PrintString (u + ox + 2, v + oy + 2), n$
Color &HFFFFFFFF: _PrintString (u + ox, v + oy), n$
End If
Next: Next: _Display: _Limit 30
End Sub
This is starting to get close to my highest!
b = b + ...
|
