06-11-2022, 05:34 AM
LOL your new avatar!
Here is MasterMind from SmallBASIC, maybe you will remember. Funny I never translated that Game to QB64 before tonight.
![[Image: Master-Mind.png]](https://i.ibb.co/RDMvc1h/Master-Mind.png)
Here is MasterMind from SmallBASIC, maybe you will remember. Funny I never translated that Game to QB64 before tonight.
Code: (Select All)
Option _Explicit
_Title "MasterMind" 'b+ trans 2022-06-10
'Mastermind v7.bas 2016-02-27 [B+=MGA] for SmallBASIC 0.12.2
'translated and modified from SdlBasic and forum input
'Thanks to Johnno for all his input, I used much
'v6 modified with new countingCattle function, more 3d look and color
'v7 don't need EXIT button more room for Guess button
'V7 change color selected bar
Randomize Timer
Const xmax = 800, ymax = 632
Const tw = 8
Const th = 16
Const cx = xmax / 2
Const cy = ymax / 2
Const sq = ymax
Const diam = sq / 10
Const radi = sq / 20
Const bullCowL = cx - 4 * diam - 6 * tw
Const framel = bullCowL + 5 * tw
Const cpl = cx + tw
Const cpr = cx + 2 * tw + 2 * diam
Const black = _RGB32(0, 0, 0)
Const w = _RGB32(255, 255, 255)
Const gy = _RGB32(190, 190, 205)
Const board = _RGB32(150, 150, 165)
Const b2 = _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$
Dim Shared As Long restartF, guesses, lc
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 200, 20
Dim As Long i, quit, mx, my, mb
restart:
secret$ = "": For i = 1 To 4: secret$ = secret$ + Mid$(deck$, Int(Rnd * 6) + 1, 1): Next 'one line to make secret$
Line (cx - sq / 2, 0)-(cx + sq / 2, sq), board, BF
clr$ = "R" 'screen prep and initialization
drawcontrols
Color w, board
_PrintString (cx + tw, 2), "Mastermind: 4 color code"
_PrintString (cx + tw, th + 2), " C=Cow right color only"
_PrintString (cx + tw, 2 * th + 2), " B=Bull color and spot"
guesses = 0: lc = 0
Line (framel - .5 * tw, 0)-(cx - .5 * tw, sq), b2, 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 > cpl And mx < cpr 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 > framel And mx < framel + 4 * diam And my > lc * diam And my < lc * diam + diam Then 'mouse click in the guess boxes
If mx < framel + diam Then
gues$(1) = clr$
ball framel + radi, lc * diam + radi, clr$
ElseIf mx < framel + 2 * diam Then
gues$(2) = clr$
ball framel + 1.5 * diam, lc * diam + radi, clr$
ElseIf mx < framel + 3 * diam Then
gues$(3) = clr$
ball framel + 2.5 * diam, lc * diam + radi, clr$
ElseIf mx < framel + 4 * diam Then
gues$(4) = clr$
ball framel + 3.5 * diam, lc * diam + radi, clr$
End If 'mouse in guess frame
End If ' mouse positions on click
End If 'mousebutton
checkguess
_Delay .020
Wend
Sub handleguess ()
Dim guess$, copy$
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, board
guesses = guesses + 1
copy$ = guess$
_PrintString (bullCowL, lc * diam + radi - .5 * th), countingCattle$(secret$, copy$)
If guess$ = secret$ Then
_PrintString (cx + tw, 9 * diam), "You won after" + Str$(guesses) + " guesses!"
_PrintString (cx + tw, 9 * diam + th), "zzz... press any"
Sleep
Color w, black: Cls: restartF = -1
End If
If guesses = 10 Then
_PrintString (cx + tw, 9 * diam), "The code was: " + secret$
_PrintString (cx + tw, 9 * diam + th), "zzz... press any"
Sleep
Color w, black: Cls
restartF = -1
End If
lc = lc + 1
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 (cpl, 1.5 * diam)-(cpr, 2.5 * diam), w, BF
Line (cpl + 1, 1.5 * diam + 1)-(cpr, 2.5 * diam), gy, BF 'guess box
Color black, gy
s$ = "Guess"
tx = cpl + (cpr - cpl) / 2 - tw * (Len(s$)) / 2
ty = 2 * diam - 8
_PrintString (tx, ty), s$
Else
Line (cpl, 1.5 * diam)-(cpr, 2.5 * diam), board, BF
End If
End Sub
Sub drawframe ()
'local sc,i,cc
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 framel + diam * i + radi, lc * diam + radi, rr, _RGB32(cc, cc, cc + 15)
Next
Next
End Sub
Sub drawcontrols
Dim As Long cplr
cplr = cpl + 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 (cpl + diam + tw, 3 * diam)-(cx + sq / 2, 9 * diam), board, BF
ymult = InStr(deck$, clr$)
Color black, board
_PrintString (cpl + diam + tw, (ymult + 2) * diam + radi - .5 * th), "< = Selected Color"
End Sub
Function countingCattle$ (secrt$, guss$)
Dim build$
Dim As Long bulls, cows, i, j
bulls = 0: cows = 0: build$ = ""
For i = 1 To Len(secrt$)
If Mid$(secrt$, i, 1) = Mid$(guss$, i, 1) Then bulls = bulls + 1
Next
For i = 1 To Len(secrt$) 'this destroys the copy of guess given the function
If Len(guss$) Then
For j = 1 To Len(guss$) 'every match with secret is removed from guess
If Mid$(secrt$, i, 1) = Mid$(guss$, j, 1) Then cows = cows + 1: Mid$(guss$, j, 1) = " ": Exit For
Next
End If
Next
cows = cows - bulls
If bulls Then build$ = build$ + String$(bulls, "B")
If cows Then build$ = build$ + String$(cows, "C")
If bulls = 0 And cows = 0 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 + ...