Old Games

[johnno56]

Hey guys,

I am looking for some old "text based" games in Basic that do not use "goto"... (some goto's I can convert but not all...)

Such as Mastermind; Yahtzee; Farkle etc

Thank you.

J

ps: Sucker for the classics... lol

[bplus]

LOL your new avatar!

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

[johnno56]

Oh, I remember it well... Cool... Thank you...

Yeah. The avatar was my attempt at 8 bit art... lol Just could not get the ears right... lol

[johnno56]

Slight problem... After completing the game, "press any key", restarts but will not go past the first guess for the next game...

[bplus]

Slight problem... After completing the game, "press any key", restarts but will not go past the first guess for the next game...

Oh I probably forgot to reinitialize guesses count to 0.

Put this line right after restart:

Code: (Select All)

restartF = 0: lc = 0: guesses = 0 

All Dim Shared variables back to 0.

There are some code inefficiencies like lc (loopcount) should be same as guesses I would think...

Hey I looked up Farkle last night, another dice game like Poker? Apparently a pair doesn't count for anything.

[johnno56]

Runs like a Swiss watch... Thank you, sir. Much appreciated.

[James D Jarvis]

Here's a classic.

Code: (Select All)

'HURKLE HUNT
Randomize Timer
Locate , 23: Print "H U R K L E   H U N T"
Print: Print: Print
Print "Adapted from the game 'Hurkle' as presented by Creative Computing"
Print: Print: Print
Do
    found$ = "no"
    n = 6
    g = 10
    ' change n and g to change the difficulty of the game
    Print "A Hurkle is hiding somwhere in a "; g; " by"; g; " grid."
    Print "Homebase is at 0,0 and you must guess the hurkles location."
    Print "(X is West - East,  Y  is North - South)"
    Print "Each turn you may enter your guess as an x,y coordinate."
    Print "Hints will be provided if you guess wrong."
    Print
    hx = Int(Rnd * g) + 1
    hy = Int(Rnd * g) + 1
    Do
        Print "- - - - - -"
        Print "You have "; n; " guesses left."
        Print "Where do you think the Hurkle is Hiding?"
        Input x, y
        n = n - 1
        Print
        If x = hx And y = hy Then
            found$ = "yes"
            Print "YOU FOUND THE HURKLE !"
            Print
        Else
            Print "Look ...";
            If y < hy Then Print "north";
            If y > hy Then Print "south";
            If x < hx Then Print "east"
            If x > hx Then Print "west"
            Print
        End If
    Loop Until found$ = "yes" Or n = 0
    If found$ = "yes" Then
        Print "That was just "; n; " guesses!"
    Else
        Print
        Print "SORRY YOU DON'T HAVE ANY GUESSES LEFT."
        Print
    End If

    Print
    Print "Play again ? (Yes or No)"
    Input askquit$
    askquit$ = Left$(LCase$(askquit$), 1)
Loop Until askquit$ = "n"