02-09-2025, 01:43 AM
Here's one I wrote recently that involves word-skills and strategy, LetrMart:
Code: (Select All)
' Chars Per Row is 80 , 36 rows
Common Shared CPL, Name$(), Hand$(), Plr, NP, OK$, Bad$, Pip$, Word$, Cash(), value(), Free$, Letter$(), Remain, NextL, fail
Screen _NewImage(1040, 768, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' choose monospace font
CPL = 1040 / _PrintWidth("X") ' chars per line used for centring text
_ScreenMove (_DesktopWidth - 1040) / 2, 100
Randomize Timer
Instructions
Dim Name$(4), Letter$(100), value(26) ' allow for up to 4 names while accepting them
Bad$ = "o2l16fedc": OK$ = "o3l64ceg": Pip$ = "o4l32c"
LetterDistribution:
Data "A","A","A","A","A","A","A","A","A","B","B","B","C","C","D","D","D","D","E","E","E","E","E","E","E","E"
Data "E","F","F","F","G","G","G","H","H","H","I","I","I","I","I","I","I","I","J","K","L","L","L","L","M","M"
Data "M","M","N","N","N","N","N","N","N","O","O","O","O","O","O","O","O","P","P","Q","R","R","R","R","R","R"
Data "S","S","S","S","T","T","T","T","T","T","U","U","U","U","V","V","W","W","X","Y","Y","Z"
For a = 1 To 100: Read Letter$(a): Next
LetterValues: ' for A to Z
Data 1,3,3,2,1,4,2,4,1,8,5,1,3,1,1,3,9,1,1,1,1,4,4,8,4,9
For a = 1 To 26: Read value(a): Next
ShuffleLetters:
For a = 1 To 100
swp = Int(Rnd * 100) + 1
Swap Letter$(a), Letter$(swp)
Next
_KeyClear: NP = 0
GetNames:
Locate 15, 15: Print "Enter a name for player"; NP + 1; "(Enter for no more)";
Input nm$ ' get a name
If nm$ < "A" Then Cls: GoTo SetHands ' no name entered for next player
If Len(nm$) > 6 Then nm$ = Left$(nm$, 6) ' limit name length to 8 chars
NP = NP + 1 ' ready for next name
Name$(NP) = UCase$(nm$) ' change to Upper Case
Wipe "15"
Centre Name$(NP), 15: _Delay .4 ' display name briefly
Play OK$
If NP = 4 Then GoTo SetHands
Cls
GoTo GetNames
SetHands:
If NP < 1 Then NP = 1: Plr = 1: Name$(Plr) = "ANON" ' default single player name if no names given
Dim Hand$(NP, 11), Cash(NP) ' now we can Dim arrays for each player
For a = 1 To NP
Cash(a) = 50
For b = 1 To 10
Hand$(a, b) = Letter$((a - 1) * 10 + b)
Next
Hand$(a, 11) = Chr$(249)
Next
Free$ = Letter$(NP * 10 + 1)
NextL = NP * 10 + 2
Remain = 100 - NextL
Plr = Int(Rnd * NP + 1)
PlayerGo: ' start player's turn
If passes = NP Then Done
Locate 23, 31: For a = 1 To 11: Print Hand$(Plr, a); " ";: Next ' show new hand
Cls: Print
For a = 1 To NP
yellow: Print Tab(17); a; Name$(a); Tab(30);
white
For b = 1 To 11
Print Hand$(a, b); " ";
Next
yellow: Print Space$(4); "$"; LTrim$(Str$(Cash(a))): white
Next
yellow: Locate 9, 32: Print "FREE"; Tab(41); "Pot-Luck": white
Locate 10, 34: Print Free$; Tab(45); "?": yellow ' show Free letter and Pot-Luck box
Locate 12, 29: Print "Pot contains";: white: Print Remain;: yellow: Print "letters "
txt$ = Name$(Plr) + " playing" ' announce current player
Centre txt$, 14
white ' show options
Locate 17, 30: Print "1 Take the FREE letter"
Print Tab(30); "2 Take Pot-Luck letter ($2)"
Print Tab(30); "3 Select any letter ($5)"
yellow: Centre "Your tiles", 22: white
Print Tab(31);: For a = 1 To 11: Print Hand$(Plr, a); " ";: Next ' show player's hand
Locate 35, 2: yellow: For a = 1 To 26: Print Chr$(a + 64); " ";: Next
white: For a = 1 To 26: Print Using "###"; value(a);: Next ' show letter-values
GetAction:
k$ = InKey$
k = Val(k$): If k < 1 Or k > 3 Then GoTo GetAction
Select Case k
Case 1
TakeFree
Case 2
PotLuck
Case 3
SelectLetter
Case Else
End Select
NextL = NextL + 1: Remain = Remain - 1 ' adjust next letter and remaining letter counts
yellow: Centre "Your tiles", 22: white
Print Tab(31);: For a = 1 To 11: Print Hand$(Plr, a); " ";: Next
Play OK$
NextL = NextL + 1: Remain = Remain - 1
If Remain < 1 Then Done
Locate 12, 29: Print "Pot contains";: white: Print Remain;: yellow: Print "letters "
GetWord:
yellow: Locate 27, 28: Print "What is your word";: white: Input Word$
Word$ = UCase$(Word$)
If Word$ < "A" Or Len(Word$) < 1 Then
Locate 29, 47: red: Print "No word": fail = 1: white: passes = passes + 1
Sleep 1: Wipe "29": GoTo GetValue ' if no entry made, report No Word, set Fail and jump to GetValue
End If
If passes = NP Then Done Else passes = 0
CheckLetters:
For a = 1 To Len(Word$)
L$ = Mid$(Word$, a, 1) ' get each letter from word$ (call it l$)
fail = 1 ' assume test fails
For b = 1 To 11 ' for each of player's hand letters (1 to 11)
If L$ = Hand$(Plr, b) Then ' compare l$ with each hand-letter
Hand$(Plr, b) = Chr$(249)
fail = 0
Exit For ' if it matches, remove it, remove Fail flag, and get next letter
End If
Next '
If fail = 1 Then
Locate 29, 30: red: Print L$; " is not in your hand!" ' if a letter fails, report bad letter, set Fail and jump to GetValue
white: Sleep 1: Wipe "29": GoTo GetValue
End If
Next
CheckWord:
fail = 1 ' set Found flag to fail
Open "R_ALL15" For Random As #1 Len = 19 ' open Random Access dictionary
FL = LOF(1) \ 19 + 1 ' get number of words in file
bot = 0: top = FL ' set range to search all words
While Abs(top - bot) > 1
srch = Int((top + bot) / 2) ' find word at mid-point of range
Get #1, srch, a$ ' get that word (call it a$)
a$ = UCase$(a$) ' ensure a$ is upper case
Select Case a$
Case Is = Word$
fail = 0
Exit While ' if a$ = the word, stop searching
Case Is < Word$
bot = srch ' if a$ is less than the word, reduce range to top half
Case Is > Word$
top = srch ' if a$ is greater than the word, reduce range to bottom half
End Select
Wend ' repeat until either range is 1 or word is found (fail=0)
Close
Locate 29, 28
If fail = 1 Then
red: Print Tab(33); Word$; " is Not a word!"
white: Sleep 1: Wipe "29" '
Else
yellow: Print Tab(37); "Good word!";
End If
GetValue:
TotWin = 0
If fail = 1 Then
red
Play Bad$: wordval = 0
GoTo ShowWin
Else
Play OK$
For a = 1 To Len(Word$)
Win = value(Asc(Mid$(Word$, a, 1)) - 64)
TotWin = TotWin + Win ' calculate word value, call it TotWin
Next
End If
ShowWin:
Locate 27, 47: Print Word$
Print Tab(35); "You Earned $"; LTrim$(Str$(TotWin))
Cash(Plr) = Cash(Plr) + TotWin
Sleep 2
yellow
If Remain < Len(Word$) + 1 Then Done ' if not enough tiles to refill hand and provide Free, game ends
Sort:
swp = 0
For a = 1 To 10 ' for each letter-position in hand,
If Hand$(Plr, a) > Hand$(Plr, a + 1) Then
Swap Hand$(Plr, a), Hand$(Plr, a + 1) ' if greater than next letter, swap them
swp = 1 ' and set flag to indicate swap was made
End If '
Next
If swp = 1 Then GoTo Sort ' repeat swapping until no swaps are made
RefillHand:
For a = 1 To 10
If Hand$(Plr, a) = Chr$(249) Then ' find all chr$(249) in hand (to position 10)
Hand$(Plr, a) = Letter$(NextL) ' replace with next Pot letter
NextL = NextL + 1: Remain = Remain - 1 ' adjust NextL and Remain
End If
Next
Locate 23, 31
For a = 1 To 11: Print Hand$(Plr, a); " ";: Next ' show new hand
For a = 1 To NP
yellow: Print Tab(17); a; Name$(a); Tab(30); ' show all hands
white
For b = 1 To 11
Print Hand$(a, b); " ";
Next
yellow: Print Space$(4); "$"; LTrim$(Str$(Cash(a))): white
Next
Plr = Plr + 1: If Plr > NP Then Plr = 1
GoTo PlayerGo
Sub SortHand ' used letters were replaced with Chr$(249) (greater than z)
Swapping:
swp = 0
For a = 1 To 10 ' for each letter-position in hand,
If Hand$(Plr, a) > Hand$(Plr, a + 1) Then
Swap Hand$(Plr, a), Hand$(Plr, a + 1) ' if greater than next letter, swap them
swp = 1 ' and set flag to indicate swap was made
End If '
Next
If swp = 1 Then GoTo Swapping ' repeat swapping until no swaps are made
For a = 1 To 10
If Hand$(Plr, a) = Chr$(249) Then ' find all chr$(249) in hand (to position 10)
Hand$(Plr, a) = Letter$(NextL) ' replace with next Pot letter
NextL = NextL + 1: Remain = Remain - 1 ' adjust NextL and Remain
End If
Next
Locate 23, 31: For a = 1 To 11: Print Hand$(Plr, a); " ";: Next ' show new hand
End Sub
Sub TakeFree
Play Pip$
yellow: Centre "Taking free letter", 25: _Delay .5: Wipe "25"
Locate 10, 34: Print " "
Hand$(Plr, 11) = Free$
Free$ = Letter$(NextL)
Locate 23, 31: For a = 1 To 11: Print Hand$(Plr, a); " ";: Next
End Sub
Sub PotLuck
If Cash(Plr) < 2 Then
Play Bad$: red: Centre "Sorry, not enough cash", 25: white
_Delay .5: Wipe "25"
Exit Sub
End If
yellow: Play Pip$: Play Pip$
Centre "Taking Pot-Luck", 25: _Delay .5: Wipe "25"
Hand$(Plr, 11) = Letter$(NextL)
Locate 23, 31: For a = 1 To 11: Print Hand$(Plr, a); " ";: Next
End Sub
Sub SelectLetter
If Cash(Plr) < 5 Then
Play Bad$: red: Centre "Sorry, not enough cash", 25: white
Sleep 2: Locate 25, 30: Wipe "25"
Exit Sub
End If
Play Pip$: Play Pip$: Play Pip$
yellow: Centre "Selecting a Letter ($10)", 25: _Delay 1
Centre " Press the letter to buy ", 25
ChooseLetter:
k$ = InKey$
Select Case k$
Case "A" To "Z"
Hand$(Plr, 11) = k$
Case "a" To "z"
Hand$(Plr, 11) = UCase$(k$)
Case Else
GoTo ChooseLetter
End Select
Locate 23, 31: For a = 1 To 11: Print Hand$(Plr, a); " ";: Next
Wipe "25"
End Sub
Sub Done ' game ended
Play "o2l32cego3cego4c"
yellow
For a = 1 To 5
Centre "Game over - no Pot letters left!", 12: _Delay .4: Wipe "12": _Delay .4
Next
Cls
For a = 1 To NP
Cls
For b = 1 To 10
Cash(a) = Cash(a) - value(Asc(Mid$(Word$, a, 1)) - 64) ' reduce ech player's cash by value of their hand
Next
Next
Centre "Final Scores", 10: white
Locate 12, 1
For a = 1 To NP
yellow: Print Tab(20); Name$(a); Tab(30); ' print player's name
white
For b = 1 To 10
Print Hand$(a, b); " "; ' show their hand
Next
yellow: Print Space$(4); "$"; LTrim$(Str$(Cash(a))): white ' show their cash
Next
Winr = 1 ' assume first player is Winr
For a = 2 To NP ' compare each player's cash with Winr's cash
If Cash(a) > Cash(a - 1) Then Winr = a ' if this player's cash is greater, make them Winr
Next
yellow: txt$ = "And the winner is " + Name$(Winr)
Centre txt$, 17
Sleep: System
End Sub
Sub Centre (txt$, RowNumber) ' prints txt$ at centre of specified screen row number
If RowNumber < 1 Or RowNumber > 34 Then Exit Sub
ctr = Int(CPL / 2 - Len(txt$) / 2) + 1
Locate RowNumber, ctr
Print txt$
End Sub
Sub Wipe (RowNumber$) ' clears specified screen row number
If Len(RowNumber$) = 1 Then RowNumber$ = "0" + RowNumber$ ' catch single-digit line numbers
For a = 1 To Len(RowNumber$) - 1 Step 2
WL = Val(Mid$(RowNumber$, a, 2)) ' get 2 digit number of line to be wiped
Locate WL, 1: Print Space$(CPL - 1); ' print line of spaces on the line
Next
End Sub
Sub white
Color _RGB(255, 255, 255)
End Sub
Sub yellow
Color _RGB(255, 255, 0)
End Sub
Sub red
Color _RGB(255, 0, 0)
End Sub
Sub Instructions
yellow: Centre "LetterMart", 3: white: Print
Print " A word game for 1 to 4 players, requiring both strategy and word-skills.": Print
Print " A ";: yellow: Print "Pot";: white: Print " of 100 letters is provided, with each letter having a value of from"
Print " $1 to $9. Players try to build words from these letters to win cash.": Print
Print " At the start of the game, each player is dealt a ";: yellow: Print "Hand ";: white: Print "of 10 letters, and"
Print " receives ";: yellow: Print "Cash ";: white: Print "of $50. An extra letter is taken from the Pot and offered to"
Print " players as a ";: yellow: Print "Free";: white: Print " letter. Players take turns to try to form a word from"
Print " their letters, but first they must do one of three things:": Print: yellow
Print Tab(15); "1. Take the Free card and add it to their Hand";: white: Print ", or": yellow
Print Tab(15); "2. Buy a "; Chr$(34); "Pot-Luck"; Chr$(34); " letter, for $2";: white: Print ", or": yellow
Print Tab(15); "3. Buy any letter of their choice, for $5": Print: white
Print " They then lay down one or more letters, which may or may not be a word."
Print " (this allows players to discard problem tiles)."
Print " If the letters form a word, they score points based on the value of its"
Print " letters. If not, no points are scored. Their Hand is then re-filled to 10"
Print " letters, using letters from the Pot, or when none left, the Free letter."
Print " When taken, the Free letter is replaced with one from the Pot": Print
Print " Laying down letters that are of little use may be used as a strategy for"
Print " removing unwanted letters or to increase chances of gaining better ones.": Print
Print " Words are checked for validity and must have at least 2 letters. The game"
Print " ends when the last Pot letter is taken. At that point, each player's cash"
Print " is reduced by the value of their remaining hand. The player with the most"
Print " cash wins the game."
yellow: Centre "Press any key to start", 33
Sleep
Cls
End Sub
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/