06-12-2022, 12:01 AM
MasterMind 2022 update
I went though and refreshed the code in this game since Johnno was asking about it.
Code: (Select All)
Option _Explicit
_Title "MasterMind 2022" ' b+ 2022-06-11 make over b+ trans 2022-06-10
'Mastermind v7.bas 2016-02-27 [B+=MGA] for SmallBASIC 0.12.2
'
Randomize Timer
Const xmax = 800, ymax = 632, cx = xmax / 2, cy = ymax / 2
Const diam = ymax / 10 ' originally SB version was built around the bigger of xmax and ymax
Const radi = ymax / 20 ' and these dimensions all flowed from that
Const BullCowX = cx - 4 * diam - 60
Const FrameLX = BullCowX + 5 * 8 ' frame holds ball guess so Frame Left X
Const ControlPanelLX = cx + 8 ' cp = Control Panel? so Control Panel Left X
Const ControlPanelRX = cx + 2 * 8 + 2 * diam
Const black = _RGB32(0, 0, 0)
Const white = _RGB32(255, 255, 255)
Const gray = _RGB32(190, 190, 205)
Const boardC = _RGB32(150, 150, 165)
Const boardC2 = _RGB32(80, 80, 95)
Const deck$ = "RGBYOP" 'here are 6 color initials Red Green Blue Yellow Orange Purple
Dim Shared secret$, gues$(1 To 4), clr$ ' globals
Dim Shared As Long restartF, guesses, lc ' globals yes need both lc and guesses, I guess
Dim As Long i, quit, mx, my, mb ' locals
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 200, 20
restart:
restartF = 0: lc = 0: guesses = 0
secret$ = "": For i = 1 To 4: secret$ = secret$ + Mid$(deck$, Int(Rnd * 6) + 1, 1): Next 'one line to make secret$
'_Title secret$ ' for debugging
Line (cx - ymax / 2, 0)-(cx + ymax / 2, ymax), boardC, BF
clr$ = "R" 'screen prep and initialization
drawcontrols
Color white, boardC
_PrintString (cx + 66, 20), "MasterMind: 4 Color Code"
_PrintString (cx + 10, 16 + 30), "B = Bull, Right Color and Right Spot"
_PrintString (cx + 10, 2 * 16 + 35), "C = Cow, Right Color and Wrong Spot"
Line (FrameLX - 4, 0)-(cx - 4, ymax), boardC2, BF
drawframe
quit = 0
While quit = 0 'the game begins
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
If mx > ControlPanelLX And mx < ControlPanelRX And my > 1.5 * diam And my < 9 * diam Then 'click in control panel
If my < 2.5 * diam Then 'guess button clicked
handleGuess
If restartF Then GoTo restart
ElseIf my < 4 * diam Then 'clicked a color update in control panel or quit
clr$ = "R": updatecolor
ElseIf my < 5 * diam Then
clr$ = "G": updatecolor
ElseIf my < 6 * diam Then
clr$ = "B": updatecolor
ElseIf my < 7 * diam Then
clr$ = "Y": updatecolor
ElseIf my < 8 * diam Then
clr$ = "O": updatecolor
ElseIf my < 9 * diam Then
clr$ = "P": updatecolor
End If 'mouse in control box
ElseIf mx > FrameLX And mx < FrameLX + 4 * diam And my > lc * diam And my < lc * diam + diam Then 'mouse click in the guess boxes
If mx < FrameLX + diam Then
gues$(1) = clr$
ball FrameLX + radi, lc * diam + radi, clr$
ElseIf mx < FrameLX + 2 * diam Then
gues$(2) = clr$
ball FrameLX + 1.5 * diam, lc * diam + radi, clr$
ElseIf mx < FrameLX + 3 * diam Then
gues$(3) = clr$
ball FrameLX + 2.5 * diam, lc * diam + radi, clr$
ElseIf mx < FrameLX + 4 * diam Then
gues$(4) = clr$
ball FrameLX + 3.5 * diam, lc * diam + radi, clr$
End If 'mouse in guess frame
End If ' mouse positions on click
End If 'mousebutton
checkguess
_Limit 100
Wend
Sub handleGuess ()
Dim guess$, s$, tx, ty
Dim As Long OK, i
OK = 1: guess$ = ""
For i = 1 To 4
If gues$(i) = "" Then
OK = 0
Else
guess$ = guess$ + gues$(i)
End If
Next
If OK Then
Color black, boardC
guesses = guesses + 1
_PrintString (BullCowX, lc * diam + radi - .5 * 16), countingCattle$(secret$, guess$)
If guess$ = secret$ Or guesses = 10 Then
Line (ControlPanelLX, 1.5 * diam)-(ControlPanelRX, 2.5 * diam), boardC, BF 'erase button
Color black, boardC
If guess$ = secret$ Then
s$ = "You won after" + Str$(guesses) + " guesses!"
tx = ControlPanelLX + 60
ty = 2 * diam - 8
End If
If guesses = 10 Then
s$ = "The code was: " + secret$
tx = ControlPanelLX + 76
ty = 2 * diam - 8
End If
_PrintString (tx, ty), s$
s$ = "zzz... press any"
tx = ControlPanelLX + 85
ty = 2 * diam + 16
_PrintString (tx, ty), s$
Sleep
Color white, black: Cls: restartF = -1
End If
lc = lc + 1 ' do I need lc if guesses is keeping count too? yeah it's too confusing taking it out
drawframe
For i = 1 To 4: gues$(i) = "": Next
End If 'guess$ OK ends handling guess$
End Sub
Sub checkguess
Dim As Long OK, i
Dim s$, tx, ty
OK = 1
For i = 1 To 4
If gues$(i) = "" Then OK = 0
Next
If OK = 1 Then
Line (ControlPanelLX, 1.5 * diam)-(ControlPanelRX, 2.5 * diam), white, BF
Line (ControlPanelLX + 1, 1.5 * diam + 1)-(ControlPanelRX, 2.5 * diam), gray, BF 'guess box
Color black, gray
s$ = "Guess"
tx = ControlPanelLX + (ControlPanelRX - ControlPanelLX) / 2 - 8 * (Len(s$)) / 2
ty = 2 * diam - 8
_PrintString (tx, ty), s$
Else
Line (ControlPanelLX, 1.5 * diam)-(ControlPanelRX, 2.5 * diam), boardC, BF
End If
End Sub
Sub drawframe ()
Dim sc, i, rr, cc
sc = 64 / (radi - 5)
For i = 0 To 3
For rr = radi - 5 To 0 Step -1
cc = rr * sc
fcirc FrameLX + diam * i + radi, lc * diam + radi, rr, _RGB32(cc, cc, cc + 15)
Next
Next
End Sub
Sub drawcontrols
Dim As Long cplr
cplr = ControlPanelLX + radi
ball cplr, 3.5 * diam, "R"
ball cplr, 4.5 * diam, "G"
ball cplr, 5.5 * diam, "B"
ball cplr, 6.5 * diam, "Y"
ball cplr, 7.5 * diam, "O"
ball cplr, 8.5 * diam, "P"
updatecolor
End Sub
Sub updatecolor ()
Dim As Long ymult
Line (ControlPanelLX + diam + 8, 3 * diam)-(cx + ymax / 2, 9 * diam), boardC, BF
ymult = InStr(deck$, clr$)
Color black, boardC
_PrintString (ControlPanelLX + diam + 8, (ymult + 2) * diam + radi - .5 * 16), "< = Selected Color"
End Sub
Function countingCattle$ (secrt$, guss$) ' 2022 reworked and fixed
Dim build$, copyS$, copyG$
Dim As Long bulls, cows, i, j
copyS$ = secrt$: copyG$ = guss$ ' don't mess with originals
For i = 1 To 4 ' remove matching letters from both by changing the letters
If Mid$(copyS$, i, 1) = Mid$(copyG$, i, 1) Then bulls = bulls + 1: Mid$(copyS$, i, 1) = " ": Mid$(copyG$, i, 1) = "_"
Next
For i = 1 To 4 ' go through letters of guess
For j = 1 To 4 'every match with secret is removed from copy of secret and of guess
If Mid$(copyS$, j, 1) = Mid$(copyG$, i, 1) Then
cows = cows + 1: Mid$(copyS$, j, 1) = " ": Mid$(copyG$, i, 1) = "_"
Exit For
End If
Next
Next
build$ = String$(bulls, "B") + String$(cows, "C")
If build$ = "" Then build$ = "X"
countingCattle$ = build$
End Function
Sub ball (x, y, c$)
Dim sc, start, r
sc = 32 / radi: start = Int(32 / sc) - 2
For r = start To 0 Step -1
If c$ = "R" Then
fcirc x, y, r, _RGB32(255 - 6 * r * sc, 0, 0)
ElseIf c$ = "B" Then
fcirc x, y, r, _RGB32(0, 0, 255 - 6 * r * sc)
ElseIf c$ = "G" Then
fcirc x, y, r, _RGB32(0, 220 - 6 * r * sc, 0)
ElseIf c$ = "O" Then
fcirc x, y, r, _RGB32(255 - 3 * r * sc, 150 - 3 * r * sc, 0)
ElseIf c$ = "Y" Then
fcirc x, y, r, _RGB32(255 - 4 * r * sc, 255 - 4 * r * sc, 0)
ElseIf c$ = "P" Then
fcirc x, y, r, _RGB32(255 - 7 * r * sc, 0, 130 - 2 * r * sc)
End If
Next
End Sub
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
b = b + ...