01-23-2023, 12:10 AM
Well, yes, but this one has one or two features that I've never seen in other word-games, so at the risk of overloading this genre of Programs (and the mentalities of the non-lexophile group), here it is.
It's attached as a .zip file, with the dictionary folder Wordlists, which should be in the same folder as the .bas file.
It's attached as a .zip file, with the dictionary folder Wordlists, which should be in the same folder as the .bas file.
Code: (Select All)
Screen 9
_FullScreen
Randomize Timer
Common Shared k, k$, name$(), score(), flipped, minsize, winscore, plr
Common Shared wrd$, csrh, wrdpos, picked, choice, ln$, reverse$, dumwrd$, mve, found, dictword$, srch$, wordval, tryval, try$
Dim name$(2), score(2)
Color 14: Locate 8, 38: Print "Worm": Print: Print Tab(22);: Color 15: Print " An original word-game by Phil Taylor"
Print
Color 14
Print Tab(17); "Would you like to read the instructions (Y/N) ?"
Instrs:
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
If k <> 78 And k <> 110 Then instructions
Cls
name$(1) = "PLAYER 1": name$(2) = "PLAYER 2": winscore = 200
Locate 10, 9
Print " Accept defaults PLAYER 1, PLAYER 2, Win-level 200 points (Y/N) ?"
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
If k = 89 Or k = 121 Then name$(1) = "PLAYER 1": name$(2) = "PLAYER 2": winscore = 200: GoTo SetUpGame
_KeyClear
wipe "10"
Locate 10, 10: Print "Name for first player (enter for default PLAYER 1): ";
Input n$
If Len(n$) > 1 Then name$(1) = UCase$(n$)
wipe "10"
Locate 10, 10: Print "Name for second player (enter for default PLAYER 2) ";
Input n$
If Len(n$) > 1 Then name$(2) = UCase$(n$)
wipe "10"
Locate 10, 13: Print "Winning score (1=100 to 9=900, enter for default 100):";
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
If k < 49 Or k > 57 Then winscore = 100 Else winscore = (k - 48) * 100
wipe "10"
Cls
SetUpGame:
Locate 10, 2: Print "First player: "; name$(1); Tab(25); "Second player: "; name$(2); Tab(50); "Winning score level:"; winscore
flip = 1: flipped = 0
minsize = 3: plr = 1
score(1) = 0: score(2) = 0
NewWord:
If score(1) >= winscore Or score(2) >= winscore Then
Cls: Locate 10, 32: Print "We have a winner!"
Print: Print Tab(31); name$(1), score(1); Tab(31); name$(2), score(2)
Sleep
System
End If
wrd$ = Chr$(Int(Rnd * 26) + 65): csrh = 320 ' wrd$ is random letter at start
PlayerUp:
Color 14
Locate 1, 3: Print name$(1); Space$(4); score(1); Tab(30); name$(plr); " playing"; Tab(64); name$(2); Space$(4); score(2)
cut = Int((Len(wrd$) + 1) / 2): wrdpos = 40: picked = 0: flipped = 0 ' cut is number of letters at left of cursor, changes each time a letter is added
wipe "10"
Locate 10, wrdpos: Print wrd$
ShowChoices:
Color 14
Locate 1, 3: Print name$(1); Space$(4); score(1); Tab(34); name$(plr); " playing"; Tab(64); name$(2); Space$(4); score(2)
Locate 2, 33: Print "Winning Score:"; winscore
Color 15: Locate 14, 26: Print "A-Z to select a letter to add"
If picked = 0 Then Color 8
Locate 15, 6: Print "Use Left/Right arrows to change its position, then up-arrow to place it": Color 15
If Len(wrd$) < minsize Or flipped = 1 Then Color 8
Locate 16, 7: Print "1 to Claim a word 2 to Challenge a group": Color 15
If Len(wrd$) < minsize Or flipped = 1 Then Color 8
Locate 16, 53: Print "3 to Concede this round": Color 15
If Len(wrd$) < 2 Then Color 8
Locate 17, 27: Print "Down-arrow to flip the word": Color 15
Locate 18, 32: Print "Esc to close game"
Locate 19, 57: Print ""
Color 15: Locate 12, 40: Print "?"
_KeyClear
GetChoice:
PSet (csrh, 152): Draw "c14u10"
wipe "10"
Locate 10, wrdpos: Print wrd$
choice = 0
_Limit 30
choice = _KeyHit
Select Case choice
Case Is < 1 ' invalid choice
GoTo GetChoice
Case Is = 27 ' exit game
System
Case 65 To 90, 97 To 122 ' letter
If picked = 0 Then ' as long as letter not already picked...
picked = 1
letr$ = UCase$(Chr$(choice))
Locate 12, 40: Print letr$
Locate 15, 6: Print "Use Left/Right arrows to change its position, then up-arrow to place it"
GoTo GetChoice
End If
Case Is = 19200 ' left
If picked = 0 Then GoTo GetChoice ' if no letter picked yet, ignore
If cut > 0 Then ' if csr not beyond left limit...
wipe "11" ' remove csr...
csrh = csrh - 8: cut = cut - 1 ' reposition cut position and csr
End If
GoTo GetChoice
Case Is = 19712 ' right
If picked = 0 Then GoTo GetChoice ' if no letter picked yet, ignore
If cut < Len(wrd$) Then ' if csr not beyond right limit...
wipe "11" ' remove csr...
csrh = csrh + 8: cut = cut + 1 ' reposition cut position and csr
End If
GoTo GetChoice
Case Is = 18432 ' up (place letter)
flipped = 0
If picked = 1 Then
wrd$ = Left$(wrd$, cut) + letr$ + Right$(wrd$, Len(wrd$) - cut)
cut = Int((Len(wrd$) + 1) / 2)
wrdpos = 41 - cut
Locate 10, wrdpos: Print wrd$
picked = 0: flipped = 0
wipe "111617 "
csrh = 320
Locate 12, 40: Print "?"
letr$ = ""
If plr = 1 Then plr = 2 Else plr = 1
wipe "14151719"
Color 15: Locate 12, 40: Print "?"
End If
GoTo ShowChoices
Case Is = 49 ' claim word
If Len(wrd$) >= minsize And flipped = 0 Then
wordval = 0
For a = 1 To Len(wrd$): wordval = wordval + a: Next
Locate 5, 35: Print "Points Value is"; wordval
DictionaryCheck:
If _DirExists("WordLists") Then
found = 0
srch$ = "WordLists/" + Left$(wrd$, 1) ' set up file to be searched for try$
Open srch$ For Input As #1
While Not EOF(1)
Input #1, dictword$
If UCase$(dictword$) = wrd$ Then
found = 1
Exit While
End If
Wend
Close #1
Else
Locate 6, 10: Print "Is this word accepted (y/n)"
_KeyClear: k = 0
While k < 1
k = _KeyHit
Wend
If k = 110 Then found = 0
End If
If found = 0 Then
wipe "0607"
Locate 7, 35: Color 12: Print wrd$; " not found!"
If plr = 1 Then plr = 2 Else plr = 1
score(plr) = score(plr) + wordval
Else score(plr) = score(plr) + wordval
End If
Locate 9, 30: Print name$(plr); " scores"; wordval; " points"
Sleep 2
wipe "050709"
Color 14
GoTo NewWord
Else
GoTo GetChoice
End If
Case Is = 50 ' challenge word
If Len(wrd$) >= minsize And flipped = 0 Then
found = 0
wordval = 0: tryval = 0
For a = 1 To Len(wrd$): wordval = wordval + a: Next
Locate 6, 30: Print name$(plr); " challenges this group!"
If plr = 1 Then plr = 2 Else plr = 1
Print Tab(15); name$(plr); " Please type a word that contains the group";
_KeyClear
Print Tab(35);: Color 15: Input try$
try$ = UCase$(try$)
If try$ < "A" Or try$ > "Z" Then GoTo BadTry
For a = 1 To Len(try$): tryval = tryval + a: Next
If tryval > wordval Then wordval = tryval
DictSearch:
If _DirExists("WordLists") Then
found = 0
srch$ = "WordLists/" + Left$(try$, 1) ' set up file to be searched for try$
Open srch$ For Input As #1
While Not EOF(1)
Input #1, dictword$
If UCase$(dictword$) = try$ Then
found = 1
Exit While
End If
Wend
Close #1
Else
Locate 6, 10: Print "Is this word accepted (y/n)"
_KeyClear: k = 0
While k < 1
k = _KeyHit
Wend
If k = 110 Then found = 0
End If
BadTry:
If found = 0 Then
wipe "07"
Locate 7, 35: Color 12: Print try$; " Not found!"
If plr = 1 Then plr = 2 Else plr = 1
score(plr) = score(plr) + wordval
Else score(plr) = score(plr) + wordval
End If
Locate 9, 30: Print name$(plr); " scores"; wordval; " points"
Sleep 2
wipe "060709"
Color 14
GoTo NewWord
Else
GoTo GetChoice
End If
Case Is = 51 ' concede word
If Len(wrd$) >= minsize And flipped = 0 Then
wipe "0607080914151719"
wordval = 0
For a = 1 To Len(wrd$): wordval = wordval + a: Next
Locate 6, 30: Print name$(plr); " concedes this round!"
If plr = 1 Then plr = 2 Else plr = 1
score(plr) = score(plr) + wordval
Locate 9, 30: Print name$(plr); " scores"; wordval; " points"
Sleep 2
wipe "0506070809"
Color 14
GoTo NewWord
Else
GoTo GetChoice
End If
GoTo NewWord
Case Is = 20480 ' flip word
If picked = 0 Then
If flipped = 1 Then GoTo GetChoice
Locate 17, 27: Color 8: Print "Down-arrow to flip the word": Color 15
reverse$ = ""
For a = Len(wrd$) To 1 Step -1
reverse$ = reverse$ + Mid$(wrd$, a, 1)
Next
wrd$ = reverse$
flipped = 1
cut = Int((Len(wrd$) + 1) / 2): wrdpos = 41 - cut
GoTo GetChoice
End If
Case Else
GoTo GetChoice
End Select
Sub instructions
Cls: Color 14
Print Tab(32); "Worm Instructions"
Color 15
Print " A random letter is presented, and the players take turns to add one letter to"
Print " it, building towards a word, but avoiding completing it. The letter may be"
Print " placed at either end, or anywhere inside the group, thus exending the "; Chr$(34); "Worm"; Chr$(34); "."
Print
Print " If a player recognizes a completed word they may claim it, and gain points."
Print " If successful, they gain points based on its length but if not, their opponent"
Print " gains the points."
Print " The group may also be Flipped (reversed) before adding the letter (the result"
Print " of the Flip can not be claimed as a word)."
Print
Print " If they suspect that the group is not part of a real word, they may challenge,"
Print " and their opponent must then type a complete word containing the group. If"
Print " they can"; Chr$(39); "t provide a real word, the challenger gains points based on either"
Print " the size of the group or the length of their attempt, whichever is greater."
Print
Print " If a player thinks that any word formed by continuing to expand the group will"
Print " cost points, they may concede, and their opponent gains points based on the"
Print " size of the group thus far. This can help to avoid losing even more points."
Print
Print " The game ends when one player reaches the pre-set winning score."
Color 14: Print Tab(28); "Press a key to continue."
Sleep
Cls
Print
End Sub
Sub wipe (ln$)
For a = 1 To Len(ln$) - 1 Step 2
Locate Val(Mid$(ln$, a, 2)): Print Space$(80)
Next
End Sub
Sub Keypress
End Sub
Sub DictSearch
wrd$ = try$
srch$ = "WordLists/" + Left$(wrd$, 1)
wipe "14151719"
Open srch$ For Input As #1
While Not EOF(1)
Input #1, dictword$
If UCase$(dictword$) = wrd$ Then
wipe "07"
Locate 7, 35: Color 14: Print wrd$; " found!"
found = 1
Exit While
End If
Wend
Close #1
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/