02-09-2025, 01:26 AM
Code: (Select All)
Common Shared Ln$, SetNum$, Filename$, LineNum, CPL, WordPos, bad$, ok$, W$, Set$()
Common Shared Pairnum, Prev$, First$(), Last$(), Best$(), Name$(), Chain$(), Target$(), Target$, Name$
Common Shared ThisChain$, TryVert, Try$, Tries, MaxTries, Egg, Result, Rmv, Rmv$, Removed$(), Add, Add$, Added$(), Chg, Chg$, Changed$()
' Files Set1, Set2, Set3 will be created if missing, Random Access R_ALL9 is created by ListMaker
SW = 1020: sh = 720
Screen _NewImage(SW, sh, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' choose monospace font
SMode = 32
CPL = SW / _PrintWidth("X") ' find chars per line for this window width
lhs = (_DesktopWidth - CPL) / 2 ' find position for LHS of window
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' place window there
ok$ = "o3l32ceg": bad$ = "o2l16gec" ' sound strings
MaxTries = 20: WordPos = 36 ' number of tries allowed, left position of try (36 is leftmost)
Set1Data: ' easy
Data "BADGE","MEDAL","HORSE","SHEEP","SHED","HOUSE","CAR","TRUCK","MAJOR","MINOR"
Data "PASS","FAIL","STEAK","EGGS","SUN","MOON","BIRD","FISH","TOWN","CITY"
Data "COLD","HOT","LOCK","WATCH","CUP","PLATE","PARK","GARDEN","RIPE","ROTTEN"
Data "SHORT","TALL","WAR","PEACE","BIG","SMALL","DRAIN","SEWER","DRESS","SUIT"
Set2Data: ' medium
Data "MILK","HONEY","CREAM","CUSTARD","SPICE","SUGAR","RAKE","SHOVEL","WOOL","COTTON"
Data "WEED","FLOWER","EASTER","EGG","LOOK","LISTEN","FOX","HOUND","DANGER","SAFETY"
Data "COPPER","BRASS","LION","TIGER","BOX","CARTON","BOOK","PAPER","GREEN","BROWN"
Data "CHILD","ADULT","DESERT","OASIS","QUERY","RESULT","DUNCE","GENIUS","FATHER","SON"
Set3Data: ' hard
Data "PAPER","PENCIL","PRETTY","UGLY","RAISE","LOWER","ROAD","STREET","BLUNT","SHARP"
Data "BLACK","WHITE","MARS","SATURN","COVER","EXPOSE","FORWARD","REVERSE","MODEST","PROUD"
Data "MARRY","DIVORCE","CIRCLE","SQUARE","ANVIL","HAMMER","PATTERN","MODEL","FRINGE","PLAIT"
Data "DARK","LIGHT","RUBY","DIAMOND","BEDROOM","KITCHEN","ANTIQUE","VINTAGE","DUCKLING","SWAN"
Dim Set$(3, 20, 5) ' 3 sets of 20 pairs, First, Last, Best, Name and Chain
Play ok$
AlchemyDescription:
Yellow: Centre "ALCHEMY", 2: White: Print
Print " Alchemy (al/ke/mi) is the process of changing items into something different"
Print " in a mystical way, such as changing ";: Green
Print "STONE";: White: Print " into ";: Green: Print "GOLD.": White
Print " This game calls upon your skills in this art, to change a word into a"
Print " totally different one, with the least number of changes.": Print
Print " In the usual word-swap game, you repeatedly change one letter of a word for"
Print " a different one, creating a new word, until the final word is produced.": Print
Print " But in Alchemy you have another tool available to you for the task. You can"
Print " also ";: Green: Print "add";: White: Print " or ";: Green: Print "remove";: White: Print " a letter, before";: Green
Print " re-arranging";: White: Print " them, so the length of the"
Print " word may vary as you progress (to max 9 letters)."
Print " As an example, we can change STONE into GOLD with just 4 changes:"
Green: Centre "STONE - TONE - GONE - LONG - GOLD", 17: White: Print
Print " There are three sets of word-pairs provided, ranging from easy to difficult,";: Print
Print " and you are allowed up to 20 changes for each pair. A record is kept of the"
Print " best score for each pair, and if you beat one of these, your record will"
Print " replace it (you can restart these records from new at any time).": Print
Print " By the way, an ";: Green: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
Print " word-pairs is hidden (but you may have to visit Tibet to find it)!"
Yellow: Centre "Press a key to continue", 27
Sleep: Play ok$: Cls
CheckFiles: ' check 3 Sets
For A = 1 To 3
Filename$ = "Set" + LTrim$(Str$(A))
txt$ = "Checking " + Filename$
Centre txt$, 15: _Delay .5
If Not _FileExists(Filename$) Then ' re-create missing set with defaults
If A = 1 Then
Restore Set1Data
ElseIf A = 2 Then
Restore Set2Data
ElseIf A = 3 Then
Restore Set3Data
End If
Open Filename$ For Output As #1
For b = 1 To 20
Read Fst$, Lst$
Write #1, Fst$, Lst$, "21", "NOT SET", "UNSOLVED" ' write the defaults to the file
Next
Print "created "; Filename$: Sleep 1
Close: Cls
End If
Next
Chooseset: ' currently 3 sets of 20 pairs, easy,medium and hard
Centre "Choose from Set 1 to Set 3 (0 TO Exit)", 15
SetNum$ = ""
While SetNum$ < "0" Or SetNum$ > "3"
SetNum$ = InKey$
Wend
If SetNum$ = "0" Then System ' choose set 0 to exit game
Cls
ReDim First$(20), Last$(20), Best$(20), Name$(20), Chain$(20) ' key words and records of previous games
ReDim Added$(26), Removed$(9), Changed$(250) ' letter-groups of correct length for each, updated each game
ShowPairs
InviteChoosePair: ' choose a pair of words
Yellow: Centre "Choose a pair, from A to T", 29
Centre "Z to re-choose set number", 30 ' to re-select set number
Centre " Press * to reset this set's history", 31 ' to restore defaults for this set
Centre "(ESC to quit)", 32 ' to quit the game
_KeyClear: k = 0
While k < 1
_Limit 30
k = _KeyHit
Wend
Cls
Select Case k
Case Is = 42, 56 ' press * to reset this pair history to defaults
Wipe "303132"
Centre "Do you really want to remove the history for this set (y/n)?", 30
_KeyClear
k$ = ""
While k$ = ""
k$ = InKey$: Wend
If UCase$(k$) <> "Y" Then
GoTo Chooseset
Else
If SetNum$ = "1" Then
Restore Set1Data ' use set 1 word pairs
ElseIf SetNum$ = "2" Then
Restore Set2Data ' use set 2 word pairs
ElseIf SetNum$ = "3" Then
Restore Set3Data ' use set 3 word pairs
End If
Filename$ = "Set" + SetNum$
Open Filename$ For Output As #1 ' get this set's data from file
For A = 1 To 20
Read First$, Last$ ' get the word-pair from data
Write #1, First$, Last$, "21", " ?", "UNSOLVED" ' write First, Last, Best, Name, and Chain to file
Next
Close
Cls: txt$ = Filename$ + " reset"
Centre txt$, 15
Sleep 1
GoTo Chooseset
End If
Case Is = 27 ' Esc to quit
System
Case Is = 90, 122 ' Z or z to re-choose set
GoTo Chooseset
Case 65 To 84 ' selected A to T
Pairnum = k - 64 ' convert to number 1 to 20 uppercase
Case 97 To 116 ' selected a to t
Pairnum = k - 96 ' convert to number 1 to 20 lower-case
Case Else ' if it's none of these, try again
Play bad$
GoTo Chooseset
End Select
FirstLook:
Cls: ThisChain$ = "": Try$ = "" ' empty the chain for this pair
Prev$ = First$(Pairnum) ' put Start word at front of chain
TryVert = 6: remain = 21: Tries = 0
target = Val(Best$(Pairnum)): Name$ = Name$(Pairnum)
txt$ = "Target:" + Str$(target)
Centre txt$, 3 ' show target score for this pair
Yellow: Centre First$(Pairnum), 5 ' show the first word
For A = TryVert To MaxTries + 5
Print Using "##"; Tab(28); A - 5;
Centre String$(9, "."), A
Next ' show 9 dots for each try
Yellow: Centre Last$(Pairnum), 26 ' show the target word
_KeyClear
CheckNumTries:
If Tries = MaxTries Then ' check if all tries have been used
Play bad$
Wipe "30"
Red: Centre "You've Used up all of your tries, sorry!", 30
Wipe "24": White: Sleep 1
GoTo FirstLook ' if all tries used, advise and restart the same pair
End If
GetTry:
Centre String$(9, "."), TryVert
Yellow:
Wipe "30"
txt$ = "You have" + Str$(20 - Tries) + " tries remaining"
Centre txt$, 30
Yellow
Locate 5, 50: Print "Added"; Tab(60); "Removed"
Locate 5, 2: Print "Enter your word"
Locate 6, 2: Print "Space to restart from top" ' start over with this pair
Locate 7, 2: Print "(restarts your tries)"
Locate 8, 2: Print "Esc to quit"
White
Locate TryVert, WordPos - 1: Print "?"; '
_KeyClear '
Play "o3l32g"
GetAKey:
k = _KeyHit ' get current key-press
_Limit 30
If k < 1 Then GoTo GetAKey
Select Case k
Case Is = 27
System ' if Esc pressed, quit the game
Case Is = 32
GoTo FirstLook ' Space re-starts this pair
Case 65 To 90, 97 To 122
GoTo Letters ' if a letter was pressed, get a word
Case Else
GoTo GetTry ' any other key, ignore
End Select
Letters:
Locate TryVert, WordPos - 1
Input Try$
If Len(Try$) < 2 Or Len(Try$) > 9 Then ' check length is 2 to 9 letters
Play bad$
Red: Centre "Words from 2 to 9 letters only allowed", 29
Sleep 2: Wipe "29": White
Locate TryVert, WordPos
Print Space$(20) ' if length is wrong, erase,
GoTo GetTry ' and start this try again
End If
Try$ = UCase$(Try$)
Tries = Tries + 1
Locate TryVert, WordPos - 5: Print Space$(12)
Centre Space$(9), TryVert
Centre Try$, TryVert
CheckWord ' Call Sub to Check the Player's Word
TryVert = TryVert + 1
_KeyClear
GoTo CheckNumTries
' ------------------------------------------------------------------- subs below -------------------------------------------------------------------
Sub ShowPairs
Filename$ = "Set" + SetNum$
Open Filename$ For Input As #1
For A = 1 To 20
Input #1, First$(A), Last$(A), Best$(A), Name$(A), Chain$(A)
Next
Close
txt$ = Filename$ + " Word Pairs "
Yellow: Centre txt$, 5 ' show pair details, but don't show chains
Print: Print Tab(18); "Pair"; Tab(26); "From"; Tab(37); "To"; Tab(44); "Best"; Tab(52); "By"
White
For A = 1 To 20
Print Tab(19); Chr$(A + 64); Tab(26); First$(A); Tab(36); Last$(A); Tab(45); Best$(A); Tab(50); Name$(A)
Next
Close
Play ok$
End Sub
Sub CheckWord ' check number of changes, valid word
Result = 0 ' check will be 0 invalid word, 1 too many changes, 2 word ok but not final, or 3 solved
Add$ = "": Rmv$ = "" ' string of letters added or removed by player
CountAddedLetters: ' Find letters in Try$ that were not in Prev$ (added)
temp$ = Prev$ ' back up prev$ before checking
For A = 1 To Len(Try$) '
L$ = Mid$(Try$, A, 1) ' get a letter from try$,
po = InStr(temp$, L$) ' find its position in temp$, if any
If po = 0 Then ' if not in temp$, it was added, if not found...
Add$ = Add$ + L$ ' add to Added$
Else ' replace duplicates with space to stop re-finding
temp$ = Left$(temp$, po - 1) + " " + Right$(temp$, Len(temp$) - po)
End If
Next
CountRemovedLetters: ' Find letters in prev$ that are not in try$ (removed)
temp$ = Try$ ' backup try$ before checking
For A = 1 To Len(Prev$)
L$ = Mid$(Prev$, A, 1) ' get a letter from prev$
po = InStr(temp$, L$) ' find its position in try$, if any
If po = 0 Then ' if not in temp$ it has been removed,
Rmv$ = Rmv$ + L$ ' add to Removed$
Else ' replace duplicates with space to stop re-finding
temp$ = Left$(temp$, po - 1) + " " + Right$(temp$, Len(temp$) - po)
End If
Next
Locate TryVert, 50: Print Add$; Tab(60); Rmv$
ResultOfCount: ' check number of added and removed letters
If Len(Add$) > 1 Or Len(Rmv$) > 1 Then
Result = 1 ' flag too many changes with Result = 1
White
GoTo ChecksFinished ' bad result, no more checking needed
End If
DictionaryCheck: ' number of changes was ok, result is zero
Close
Open "R_ALL9" For Random As #1 Len = 13 ' random access file, longest word 9 letters
FL = LOF(1) \ 13 + 1 ' get number of words in dictionary (File Length)
Bot = 0: Top = FL
While Abs(Top - Bot) > 1
srch = Int((Top + Bot) / 2) ' set section of dictionary to search
Get #1, srch, W$ ' get a word from dictionary at srch point
W$ = UCase$(W$)
Select Case W$
Case Is < Try$ ' try$ is greater than dictionary word
Bot = srch ' move search forward
Case Is > Try$ ' try$ is less than dictionary word
Top = srch ' move search back
End Select
If Len(Try$) = 3 And Mid$(Try$, 3, 1) = Chr$(75) And Mid$(Try$, 2, 1) = Chr$(65) And Mid$(Try$, 1, 1) = Chr$(89) And Egg = 0 Then
Egg = 1: GotEgg: Run ' Easter-Egg found
End If
If Try$ = Last$(Pairnum) Then
Txt$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Result = 3 ' flag solved with result = 2
Yellow: Centre Txt$, 31
Centre Try$, TryVert
Exit While
ElseIf Try$ = W$ Then
Result = 2 ' flag good word not final with result = 3
Centre Try$, TryVert
Exit While
End If
Wend
Close
ChecksFinished: '
Select Case Result
Case Is = 0 ' word failed - invalid word
Wipe "30"
Red: Centre "Invalid word!", 30
Red: Centre Try$, TryVert
Play bad$
Sleep 2
ThisChain$ = ThisChain$ + " " + String$(Len(Try$), "*") + " - "
Wipe "30" ' if result = 0 it's an invalid word, Result still zero
White
Case Is = 1
Wipe "30"
Red: Centre "Too many changes!", 30
Red: Centre Try$, TryVert
Play bad$
Sleep 2
ThisChain$ = ThisChain$ + " " + String$(Len(Try$), "*") + " - "
Wipe "30" ' if result = 0 it's an invalid word, Result still zero
White
Case Is = 2 ' word is ok but is not Last$
Centre Try$, TryVert
ThisChain$ = ThisChain$ + Try$ + " - "
Prev$ = Try$
Case Is = 3 ' word ok and last word is found
Txt$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Yellow: Centre Txt$, 31
Centre Try$, TryVert
ThisChain$ = First$(Pairnum) + " - " + ThisChain$ + Try$ ' complete the changes chain
If Len(ThisChain$) > CPL - 8 Then ThisChain$ = ThisChain$ + Chr$(13)
Sleep 1
FinishedPair
Wipe "3031"
End Select
End Sub
Sub FinishedPair
Play ok$: Play ok$: Cls: Yellow
Txt$ = "You did it in " + LTrim$(Str$(Tries)) + " changes"
Centre Txt$, 15
If Tries < Val(Best$(Pairnum)) Then ' if this beats the Best for the current round,
Centre "New record! Enter your name (or <ENTER> for anonymous) ", 16
Locate 16, 63: Input WinName$ ' get the player's name,
If Len(WinName$) < 2 Then WinName$ = "(ANON)"
Name$(Pairnum) = UCase$(WinName$) ' place Name of best player for this pair in array,
Best$(Pairnum) = LTrim$(Str$(Tries)) ' place Best score for this pair in array,
Chain$(Pairnum) = ThisChain$ ' as this beats previous best, update chain$,
Filename$ = "Set" + SetNum$ '
Open Filename$ For Output As #1
Cls
For A = 1 To 20 '
Write #1, First$(A), Last$(A), Best$(A), Name$(A), Chain$(A) ' and re-write the history file for this set
Next
Close
End If
Cls
Yellow
Txt$ = "Best for this pair: " + Best$(Pairnum) + " by " + Name$(Pairnum)
Centre Txt$, 15
White: Locate 17, 1: Print ThisChain$
Play ok$
Yellow: Centre "Press a key", 19
Sleep
Run
End Sub
Sub Wipe (LN$) ' LN$ is 2-digit lines ("0122" is lines 1 and 22)
For A = 1 To Len(LN$) - 1 Step 2 ' get 2 digits for line to be wiped,
wl = Val(Mid$(LN$, A, 2)) ' and erase that line
Locate wl, 1: Print Space$(CPL);
Next
End Sub
Sub Centre (Txt$, LineNum) ' centres text on selected line
Ctr = Int(CPL / 2 - Len(Txt$) / 2) + 1 ' centre is half of Chars Per Line minus half Txt$ length
Locate LineNum, Ctr
Print Txt$
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Green
Color _RGB(0, 255, 0)
End Sub
Sub GotEgg
Cls
Yellow: Centre "Congratulations, you found the Easter Egg,", 15
Centre "This allows you to see all previous record results!", 16
Sleep 2: Cls
For A = 1 To 3
Close
Filename$ = "Set" + LTrim$(Str$(A))
Centre Filename$, 2
Open Filename$ For Input As #1
For b = 1 To 20
Yellow
For C = 1 To 2
Input #1, chain$
Print chain$; " ";
Next
For C = 1 To 2
Green
Input #1, chain$
Print chain$; " ";
Next
White
Input #1, chain$
Print chain$; " ";
Print
Next
Centre "Press a key", 32
Sleep
Cls
Next
End Sub
Common Shared Ln$, SetNum$, Filename$, LineNum, CPL, WordPos, bad$, ok$, W$, Set$()
Common Shared Pairnum, Prev$, First$(), Last$(), Best$(), Name$(), Chain$(), Target$(), Target$, Name$
Common Shared ThisChain$, TryVert, Try$, Tries, MaxTries, Egg, Result, Rmv, Rmv$, Removed$(), Add, Add$, Added$(), Chg, Chg$, Changed$()
' Files Set1, Set2, Set3 will be created if missing, Random Access R_ALL9 is created by ListMaker
SW = 1020: sh = 720
Screen _NewImage(SW, sh, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' choose monospace font
SMode = 32
CPL = SW / _PrintWidth("X") ' find chars per line for this window width
lhs = (_DesktopWidth - CPL) / 2 ' find position for LHS of window
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' place window there
ok$ = "o3l32ceg": bad$ = "o2l16gec" ' sound strings
MaxTries = 20: WordPos = 36 ' number of tries allowed, left position of try (36 is leftmost)
Set1Data: ' easy
Data "BADGE","MEDAL","HORSE","SHEEP","SHED","HOUSE","CAR","TRUCK","MAJOR","MINOR"
Data "PASS","FAIL","STEAK","EGGS","SUN","MOON","BIRD","FISH","TOWN","CITY"
Data "COLD","HOT","LOCK","WATCH","CUP","PLATE","PARK","GARDEN","RIPE","ROTTEN"
Data "SHORT","TALL","WAR","PEACE","BIG","SMALL","DRAIN","SEWER","DRESS","SUIT"
Set2Data: ' medium
Data "MILK","HONEY","CREAM","CUSTARD","SPICE","SUGAR","RAKE","SHOVEL","WOOL","COTTON"
Data "WEED","FLOWER","EASTER","EGG","LOOK","LISTEN","FOX","HOUND","DANGER","SAFETY"
Data "COPPER","BRASS","LION","TIGER","BOX","CARTON","BOOK","PAPER","GREEN","BROWN"
Data "CHILD","ADULT","DESERT","OASIS","QUERY","RESULT","DUNCE","GENIUS","FATHER","SON"
Set3Data: ' hard
Data "PAPER","PENCIL","PRETTY","UGLY","RAISE","LOWER","ROAD","STREET","BLUNT","SHARP"
Data "BLACK","WHITE","MARS","SATURN","COVER","EXPOSE","FORWARD","REVERSE","MODEST","PROUD"
Data "MARRY","DIVORCE","CIRCLE","SQUARE","ANVIL","HAMMER","PATTERN","MODEL","FRINGE","PLAIT"
Data "DARK","LIGHT","RUBY","DIAMOND","BEDROOM","KITCHEN","ANTIQUE","VINTAGE","DUCKLING","SWAN"
Dim Set$(3, 20, 5) ' 3 sets of 20 pairs, First, Last, Best, Name and Chain
Play ok$
AlchemyDescription:
Yellow: Centre "ALCHEMY", 2: White: Print
Print " Alchemy (al/ke/mi) is the process of changing items into something different"
Print " in a mystical way, such as changing ";: Green
Print "STONE";: White: Print " into ";: Green: Print "GOLD.": White
Print " This game calls upon your skills in this art, to change a word into a"
Print " totally different one, with the least number of changes.": Print
Print " In the usual word-swap game, you repeatedly change one letter of a word for"
Print " a different one, creating a new word, until the final word is produced.": Print
Print " But in Alchemy you have another tool available to you for the task. You can"
Print " also ";: Green: Print "add";: White: Print " or ";: Green: Print "remove";: White: Print " a letter, before";: Green
Print " re-arranging";: White: Print " them, so the length of the"
Print " word may vary as you progress (to max 9 letters)."
Print " As an example, we can change STONE into GOLD with just 4 changes:"
Green: Centre "STONE - TONE - GONE - LONG - GOLD", 17: White: Print
Print " There are three sets of word-pairs provided, ranging from easy to difficult,";: Print
Print " and you are allowed up to 20 changes for each pair. A record is kept of the"
Print " best score for each pair, and if you beat one of these, your record will"
Print " replace it (you can restart these records from new at any time).": Print
Print " By the way, an ";: Green: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
Print " word-pairs is hidden (but you may have to visit Tibet to find it)!"
Yellow: Centre "Press a key to continue", 27
Sleep: Play ok$: Cls
CheckFiles: ' check 3 Sets
For A = 1 To 3
Filename$ = "Set" + LTrim$(Str$(A))
txt$ = "Checking " + Filename$
Centre txt$, 15: _Delay .5
If Not _FileExists(Filename$) Then ' re-create missing set with defaults
If A = 1 Then
Restore Set1Data
ElseIf A = 2 Then
Restore Set2Data
ElseIf A = 3 Then
Restore Set3Data
End If
Open Filename$ For Output As #1
For b = 1 To 20
Read Fst$, Lst$
Write #1, Fst$, Lst$, "21", "NOT SET", "UNSOLVED" ' write the defaults to the file
Next
Print "created "; Filename$: Sleep 1
Close: Cls
End If
Next
Chooseset: ' currently 3 sets of 20 pairs, easy,medium and hard
Centre "Choose from Set 1 to Set 3 (0 TO Exit)", 15
SetNum$ = ""
While SetNum$ < "0" Or SetNum$ > "3"
SetNum$ = InKey$
Wend
If SetNum$ = "0" Then System ' choose set 0 to exit game
Cls
ReDim First$(20), Last$(20), Best$(20), Name$(20), Chain$(20) ' key words and records of previous games
ReDim Added$(26), Removed$(9), Changed$(250) ' letter-groups of correct length for each, updated each game
ShowPairs
InviteChoosePair: ' choose a pair of words
Yellow: Centre "Choose a pair, from A to T", 29
Centre "Z to re-choose set number", 30 ' to re-select set number
Centre " Press * to reset this set's history", 31 ' to restore defaults for this set
Centre "(ESC to quit)", 32 ' to quit the game
_KeyClear: k = 0
While k < 1
_Limit 30
k = _KeyHit
Wend
Cls
Select Case k
Case Is = 42, 56 ' press * to reset this pair history to defaults
Wipe "303132"
Centre "Do you really want to remove the history for this set (y/n)?", 30
_KeyClear
k$ = ""
While k$ = ""
k$ = InKey$: Wend
If UCase$(k$) <> "Y" Then
GoTo Chooseset
Else
If SetNum$ = "1" Then
Restore Set1Data ' use set 1 word pairs
ElseIf SetNum$ = "2" Then
Restore Set2Data ' use set 2 word pairs
ElseIf SetNum$ = "3" Then
Restore Set3Data ' use set 3 word pairs
End If
Filename$ = "Set" + SetNum$
Open Filename$ For Output As #1 ' get this set's data from file
For A = 1 To 20
Read First$, Last$ ' get the word-pair from data
Write #1, First$, Last$, "21", " ?", "UNSOLVED" ' write First, Last, Best, Name, and Chain to file
Next
Close
Cls: txt$ = Filename$ + " reset"
Centre txt$, 15
Sleep 1
GoTo Chooseset
End If
Case Is = 27 ' Esc to quit
System
Case Is = 90, 122 ' Z or z to re-choose set
GoTo Chooseset
Case 65 To 84 ' selected A to T
Pairnum = k - 64 ' convert to number 1 to 20 uppercase
Case 97 To 116 ' selected a to t
Pairnum = k - 96 ' convert to number 1 to 20 lower-case
Case Else ' if it's none of these, try again
Play bad$
GoTo Chooseset
End Select
FirstLook:
Cls: ThisChain$ = "": Try$ = "" ' empty the chain for this pair
Prev$ = First$(Pairnum) ' put Start word at front of chain
TryVert = 6: remain = 21: Tries = 0
target = Val(Best$(Pairnum)): Name$ = Name$(Pairnum)
txt$ = "Target:" + Str$(target)
Centre txt$, 3 ' show target score for this pair
Yellow: Centre First$(Pairnum), 5 ' show the first word
For A = TryVert To MaxTries + 5
Print Using "##"; Tab(28); A - 5;
Centre String$(9, "."), A
Next ' show 9 dots for each try
Yellow: Centre Last$(Pairnum), 26 ' show the target word
_KeyClear
CheckNumTries:
If Tries = MaxTries Then ' check if all tries have been used
Play bad$
Wipe "30"
Red: Centre "You've Used up all of your tries, sorry!", 30
Wipe "24": White: Sleep 1
GoTo FirstLook ' if all tries used, advise and restart the same pair
End If
GetTry:
Centre String$(9, "."), TryVert
Yellow:
Wipe "30"
txt$ = "You have" + Str$(20 - Tries) + " tries remaining"
Centre txt$, 30
Yellow
Locate 5, 50: Print "Added"; Tab(60); "Removed"
Locate 5, 2: Print "Enter your word"
Locate 6, 2: Print "Space to restart from top" ' start over with this pair
Locate 7, 2: Print "(restarts your tries)"
Locate 8, 2: Print "Esc to quit"
White
Locate TryVert, WordPos - 1: Print "?"; '
_KeyClear '
Play "o3l32g"
GetAKey:
k = _KeyHit ' get current key-press
_Limit 30
If k < 1 Then GoTo GetAKey
Select Case k
Case Is = 27
System ' if Esc pressed, quit the game
Case Is = 32
GoTo FirstLook ' Space re-starts this pair
Case 65 To 90, 97 To 122
GoTo Letters ' if a letter was pressed, get a word
Case Else
GoTo GetTry ' any other key, ignore
End Select
Letters:
Locate TryVert, WordPos - 1
Input Try$
If Len(Try$) < 2 Or Len(Try$) > 9 Then ' check length is 2 to 9 letters
Play bad$
Red: Centre "Words from 2 to 9 letters only allowed", 29
Sleep 2: Wipe "29": White
Locate TryVert, WordPos
Print Space$(20) ' if length is wrong, erase,
GoTo GetTry ' and start this try again
End If
Try$ = UCase$(Try$)
Tries = Tries + 1
Locate TryVert, WordPos - 5: Print Space$(12)
Centre Space$(9), TryVert
Centre Try$, TryVert
CheckWord ' Call Sub to Check the Player's Word
TryVert = TryVert + 1
_KeyClear
GoTo CheckNumTries
' ------------------------------------------------------------------- subs below -------------------------------------------------------------------
Sub ShowPairs
Filename$ = "Set" + SetNum$
Open Filename$ For Input As #1
For A = 1 To 20
Input #1, First$(A), Last$(A), Best$(A), Name$(A), Chain$(A)
Next
Close
txt$ = Filename$ + " Word Pairs "
Yellow: Centre txt$, 5 ' show pair details, but don't show chains
Print: Print Tab(18); "Pair"; Tab(26); "From"; Tab(37); "To"; Tab(44); "Best"; Tab(52); "By"
White
For A = 1 To 20
Print Tab(19); Chr$(A + 64); Tab(26); First$(A); Tab(36); Last$(A); Tab(45); Best$(A); Tab(50); Name$(A)
Next
Close
Play ok$
End Sub
Sub CheckWord ' check number of changes, valid word
Result = 0 ' check will be 0 invalid word, 1 too many changes, 2 word ok but not final, or 3 solved
Add$ = "": Rmv$ = "" ' string of letters added or removed by player
CountAddedLetters: ' Find letters in Try$ that were not in Prev$ (added)
temp$ = Prev$ ' back up prev$ before checking
For A = 1 To Len(Try$) '
L$ = Mid$(Try$, A, 1) ' get a letter from try$,
po = InStr(temp$, L$) ' find its position in temp$, if any
If po = 0 Then ' if not in temp$, it was added, if not found...
Add$ = Add$ + L$ ' add to Added$
Else ' replace duplicates with space to stop re-finding
temp$ = Left$(temp$, po - 1) + " " + Right$(temp$, Len(temp$) - po)
End If
Next
CountRemovedLetters: ' Find letters in prev$ that are not in try$ (removed)
temp$ = Try$ ' backup try$ before checking
For A = 1 To Len(Prev$)
L$ = Mid$(Prev$, A, 1) ' get a letter from prev$
po = InStr(temp$, L$) ' find its position in try$, if any
If po = 0 Then ' if not in temp$ it has been removed,
Rmv$ = Rmv$ + L$ ' add to Removed$
Else ' replace duplicates with space to stop re-finding
temp$ = Left$(temp$, po - 1) + " " + Right$(temp$, Len(temp$) - po)
End If
Next
Locate TryVert, 50: Print Add$; Tab(60); Rmv$
ResultOfCount: ' check number of added and removed letters
If Len(Add$) > 1 Or Len(Rmv$) > 1 Then
Result = 1 ' flag too many changes with Result = 1
White
GoTo ChecksFinished ' bad result, no more checking needed
End If
DictionaryCheck: ' number of changes was ok, result is zero
Close
Open "R_ALL9" For Random As #1 Len = 13 ' random access file, longest word 9 letters
FL = LOF(1) \ 13 + 1 ' get number of words in dictionary (File Length)
Bot = 0: Top = FL
While Abs(Top - Bot) > 1
srch = Int((Top + Bot) / 2) ' set section of dictionary to search
Get #1, srch, W$ ' get a word from dictionary at srch point
W$ = UCase$(W$)
Select Case W$
Case Is < Try$ ' try$ is greater than dictionary word
Bot = srch ' move search forward
Case Is > Try$ ' try$ is less than dictionary word
Top = srch ' move search back
End Select
If Len(Try$) = 3 And Mid$(Try$, 3, 1) = Chr$(75) And Mid$(Try$, 2, 1) = Chr$(65) And Mid$(Try$, 1, 1) = Chr$(89) And Egg = 0 Then
Egg = 1: GotEgg: Run ' Easter-Egg found
End If
If Try$ = Last$(Pairnum) Then
Txt$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Result = 3 ' flag solved with result = 2
Yellow: Centre Txt$, 31
Centre Try$, TryVert
Exit While
ElseIf Try$ = W$ Then
Result = 2 ' flag good word not final with result = 3
Centre Try$, TryVert
Exit While
End If
Wend
Close
ChecksFinished: '
Select Case Result
Case Is = 0 ' word failed - invalid word
Wipe "30"
Red: Centre "Invalid word!", 30
Red: Centre Try$, TryVert
Play bad$
Sleep 2
ThisChain$ = ThisChain$ + " " + String$(Len(Try$), "*") + " - "
Wipe "30" ' if result = 0 it's an invalid word, Result still zero
White
Case Is = 1
Wipe "30"
Red: Centre "Too many changes!", 30
Red: Centre Try$, TryVert
Play bad$
Sleep 2
ThisChain$ = ThisChain$ + " " + String$(Len(Try$), "*") + " - "
Wipe "30" ' if result = 0 it's an invalid word, Result still zero
White
Case Is = 2 ' word is ok but is not Last$
Centre Try$, TryVert
ThisChain$ = ThisChain$ + Try$ + " - "
Prev$ = Try$
Case Is = 3 ' word ok and last word is found
Txt$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Yellow: Centre Txt$, 31
Centre Try$, TryVert
ThisChain$ = First$(Pairnum) + " - " + ThisChain$ + Try$ ' complete the changes chain
If Len(ThisChain$) > CPL - 8 Then ThisChain$ = ThisChain$ + Chr$(13)
Sleep 1
FinishedPair
Wipe "3031"
End Select
End Sub
Sub FinishedPair
Play ok$: Play ok$: Cls: Yellow
Txt$ = "You did it in " + LTrim$(Str$(Tries)) + " changes"
Centre Txt$, 15
If Tries < Val(Best$(Pairnum)) Then ' if this beats the Best for the current round,
Centre "New record! Enter your name (or <ENTER> for anonymous) ", 16
Locate 16, 63: Input WinName$ ' get the player's name,
If Len(WinName$) < 2 Then WinName$ = "(ANON)"
Name$(Pairnum) = UCase$(WinName$) ' place Name of best player for this pair in array,
Best$(Pairnum) = LTrim$(Str$(Tries)) ' place Best score for this pair in array,
Chain$(Pairnum) = ThisChain$ ' as this beats previous best, update chain$,
Filename$ = "Set" + SetNum$ '
Open Filename$ For Output As #1
Cls
For A = 1 To 20 '
Write #1, First$(A), Last$(A), Best$(A), Name$(A), Chain$(A) ' and re-write the history file for this set
Next
Close
End If
Cls
Yellow
Txt$ = "Best for this pair: " + Best$(Pairnum) + " by " + Name$(Pairnum)
Centre Txt$, 15
White: Locate 17, 1: Print ThisChain$
Play ok$
Yellow: Centre "Press a key", 19
Sleep
Run
End Sub
Sub Wipe (LN$) ' LN$ is 2-digit lines ("0122" is lines 1 and 22)
For A = 1 To Len(LN$) - 1 Step 2 ' get 2 digits for line to be wiped,
wl = Val(Mid$(LN$, A, 2)) ' and erase that line
Locate wl, 1: Print Space$(CPL);
Next
End Sub
Sub Centre (Txt$, LineNum) ' centres text on selected line
Ctr = Int(CPL / 2 - Len(Txt$) / 2) + 1 ' centre is half of Chars Per Line minus half Txt$ length
Locate LineNum, Ctr
Print Txt$
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Green
Color _RGB(0, 255, 0)
End Sub
Sub GotEgg
Cls
Yellow: Centre "Congratulations, you found the Easter Egg,", 15
Centre "This allows you to see all previous record results!", 16
Sleep 2: Cls
For A = 1 To 3
Close
Filename$ = "Set" + LTrim$(Str$(A))
Centre Filename$, 2
Open Filename$ For Input As #1
For b = 1 To 20
Yellow
For C = 1 To 2
Input #1, chain$
Print chain$; " ";
Next
For C = 1 To 2
Green
Input #1, chain$
Print chain$; " ";
Next
White
Input #1, chain$
Print chain$; " ";
Print
Next
Centre "Press a key", 32
Sleep
Cls
Next
End Sub
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/