Screen _NewImage(1040, 768, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' monospace font
CPR = 1040 / _PrintWidth("X") ' 80 - Chars Per Line for centring text
_ScreenMove (_DesktopWidth - 1040) / 2, 100 '
ok$ = "o3l32ceg": bad$ = "o2l16gec" ' sound strings
WordPos = 36 ' lhs of word grid
Instructions
CheckFiles: ' check 3 word set files with history are present
For a = 1 To 3
Filename$ = "Set " + LTrim$(Str$(a)) + ".txt"
If Not _FileExists(Filename$) Then ' if any file is missing, recreate it
NewSet
txt$ = Filename$ + " reset": Centre txt$, 15
End If
Next
Cls
Chooseset: ' from 3 sets of 20 pairs, easy, medium and hard
ReDim First$(20), Last$(20), Best$(20), Name$(20), Chain$(20) ' create arrays for data of this set
Yellow: Centre "Choose from Set 1 to Set 3 (Esc TO Exit)", 15
SetNum$ = ""
While SetNum$ < "1" Or SetNum$ > "3"
SetNum$ = InKey$
Wend
Cls
ShowPairs ' display 20 word-pairs and Hi-scores for selected set
ChoosePair: ' choose a pair of words
Yellow: Centre "Choose a pair, from A to T", 29
Centre "or...", 30
Centre "Press Delete to reset this set's history ", 31 ' restore default scores for this set
Centre "Press Enter to re-choose Set Number", 32 ' choose a different set of words
Centre "Press ESC to quit", 33 ' to quit the game
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
Cls
Choice:
Select Case k ' allows Delete, Esc, a-t or A-T, or any other to re-choose set
Case Is = 21248 ' Delete - reset this word set history
Centre "Re-set the Best Results for this set (y/n)?", 20
_KeyClear: k$ = ""
While k$ = "": k$ = InKey$: Wend
Wipe "20"
If UCase$(k$) = "Y" Then NewSet ' only allow y to reset
GoTo Chooseset
Case Is = 27 ' Esc
System ' quit game
Case 65 To 84 ' A to T
Pairnum = k - 64 ' convert uppercase of letter to number 1 to 20
Case 97 To 116 ' a to t
Pairnum = k - 96 ' convert lower-case of letter to number 1 to 20
Case Else
GoTo Chooseset ' anything else, try again
End Select
SetField:
Cls: ThisChain$ = "" ' new Tries chain for this pair
Prev$ = First$(Pairnum) ' put Start word at front of chain
TryVert = 5: remain = 21: Tries = -1
Yellow: Centre First$(Pairnum), 5 ' show the first word of the pair
For a = TryVert + 1 To 25
Print Using "##"; Tab(28); a - 5; ' show try numbers
Centre String$(9, "."), a
Next ' show 9 dots for letters of each try
Centre Last$(Pairnum), 26 ' show the target word
GetTry:
Wipe "28"
Tries = Tries + 1: TryVert = TryVert + 1
k = 0
If Tries = 20 Then ' check if all tries have been used
Red: Centre "You've Used up all of your tries!", 28: _Delay 1
Sleep 1: Cls: GoTo Chooseset ' if they have, advise and restart the same pair
End If
try$ = "" ' empty Try$ ready for new word
Wipe "03": txt$ = "You have" + Str$(20 - Tries) + " tries remaining"
Yellow: Centre txt$, 3
Locate 5, 50: Print "Added"; Tab(60); "Removed"
Locate 5, 2: Print "Enter your word"
Locate 6, 2: Print "Backspace to restart try" ' restart this try
Locate 7, 2: Print "Space to restart this pair" ' restart this pair
Locate 8, 2: Print "Esc to quit"
White: Locate TryVert, WordPos - 1: Print "?"; ' show Try position
GetAKey:
k = 0
While k < 1: k = _KeyHit: Wend
Select Case k
Case Is = 13 ' Enter key pressed
If Len(try$) < 1 Then
GoTo GetAKey ' if no letters yet, ignore it
Else
GoTo Checks ' otherwise, this is a try so check changes (Checks sub)
End If
Case Is = 27 ' Esc
System ' quit the game
Case Is = 32 ' Space
GoTo SetField ' re-start this pair
Case Is = 8 ' backspace - restart this try
try$ = ""
Locate TryVert, WordPos - 2: Print " "; String$(9, "."); " " ' erase this try (may be overlength) and replace dots
GoTo GetAKey
Case 65 To 90, 97 To 122 ' A to Z or a to z pressed
try$ = try$ + UCase$(Chr$(k)) ' change to Uppercase
Locate TryVert, 35: Print " " ' remove input query
Centre try$, TryVert ' display Try$ in white
GoTo GetAKey ' back for next letter
Case Else
GoTo GetAKey ' ignore any other key
End Select
Checks: ' check word length, changes, Easter Egg,valid word, word found
CheckWordLength: ' 2 to 9 letters accepted
If Len(try$) > 9 Or Len(try$) < 2 Then
Play bad$: Red: Centre "Words 2 to 9 letters only!", 28: _Delay .5
Centre Space$(15), TryVert ' erase try (and overlaps)
try$ = "(size)" ' change Try$ to "Size" error indicator
Red: Centre try$, TryVert ' display it in red
GoTo GetTry
End If
AddedLetters: ' find letters in Try$ that were not in Prev$ (so are added)
Added = 0: added$ = ""
temp$ = Prev$ ' use Temp$ for testing to keep Prev$ intact
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, so ...
Added = Added + 1: added$ = added$ + l$ ' add to Added$ and increment Added count
Else ' but if found in temp$
Mid$(temp$, po) = " " ' change it to Space to prevent re-finding it
End If
Next
Locate TryVert, 52: Print added$ ' show all added letters
If Added > 1 Then ' if more than 1 letter added,
Play bad$: Red: Centre "Too many added - word rejected", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
Centre try$, TryVert ' change Try$ display to red,
ThisChain$ = ThisChain$ + " - " + LCase$(try$)
GoTo GetTry ' and get another try (don't change last good try)
End If
RemovedLetters: ' find letters in prev$ that are not in try$ (so are removed)
Removed = 0: removed$ = ""
temp$ = try$ ' use Temp$ for testing to keep Try$ intact
For a = 1 To Len(Prev$) '
l$ = Mid$(Prev$, a, 1) ' get a letter from Prev$,
po = InStr(temp$, l$) ' find its position in temp$, if any
If po = 0 Then ' if not in temp$, it was added, so
Removed = Removed + 1: removed$ = removed$ + l$ ' add to Added$ and increment Added count
Else ' but if found in temp$
Mid$(temp$, po) = " " ' change it to Space to prevent re-finding
End If
Next
Locate TryVert, 60: Print removed$ ' show removed letters
If Removed > 1 Then ' if more than 1 letter removed,
Play bad$: Red: Centre "Too many removed - word rejected", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
Centre try$, TryVert ' change Try$ display to red,
ThisChain$ = ThisChain$ + " - " + LCase$(try$)
GoTo GetTry ' and get another try (don't change last good try)
End If
CheckForEgg: ' check if try is the Easter Egg (number of changes is ok)
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) Then EggFound
CheckForSolved: ' check if try is the final word
If try$ = Last$(Pairnum) Then Done
CheckWord: ' check if Try$ is a legal word
Found = 0 ' set flag initially to not found
Open "R_ALL9" For Random As #1 Len = 13 ' open Random Access file
FL = LOF(1) \ 13 + 1 ' find number of words in file (may have been changed by player)
bot = 0: top = FL ' set bottom to first word, top to last
While Abs(top - bot) > 1 ' Do this while gap >1
srch = Int((top + bot) / 2) ' set the Search point at midway
Get #1, srch, A$ ' get that word as A$
Select Case A$
Case Is = try$ ' if this is Try$ (the word entered by the player)
Found = 1 ' flag Try$ as found
Exit While
Case Is < try$ ' if the word is less than try$ (earlier alphabetically)
bot = srch ' move bottom up to Srch
Case Is > try$ ' if the word is greater than try$ (earlier alphabetically)
top = srch ' move top down to Srch
End Select
Wend ' End of the While loop - repeat until Try$ is found or gap is 1
Close
If Found = 0 Then ' if Try$ was not found,
Play bad$: Red: Centre "Word not found!", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
ThisChain$ = ThisChain$ + " - " + try$
Centre try$, TryVert ' change the Try$ display colour to red,
Else
Play ok$
Prev$ = try$ ' try is good, change last good word to this one
ThisChain$ = ThisChain$ + " - " + try$ ' add separator beween tries for later display
End If
Centre try$, TryVert ' change Try$ display to appropriate colour
White
GoTo GetTry
Sub Done ' solved
Play ok$: Play ok$
Tries = Tries + 1 ' add the last try to the count
Txt$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Yellow: Centre Txt$, 30: Sleep 2: Cls
If Tries < Val(Best$(Pairnum)) Then NewRecord ' if better (lower) than the recorded Best, write in records
Run
End Sub
Sub NewRecord ' new low achieved
Centre "A new record for this pair!", 15
_KeyClear
Centre "What name would you like to use (Enter for anonymous) ", 17
Locate 17, 66: Input WinName$ ' get the player's name,
If Len(WinName$) < 2 Then WinName$ = "(ANON)" ' if no name given, use default ANON
WinName$ = UCase$(WinName$)
Wipe "17": Centre WinName$, 17
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) = First$(Pairnum) + ThisChain$ + " - " + Last$(Pairnum) ' create new record for the the Chain$ sequence
Filename$ = "Set " + SetNum$ + ".txt" ' Open Filename$ For Output As #1 ' open the history file for this set"
Open Filename$ For Output As #1
For a = 1 To 20 '
Write #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a) ' re-write the chain data for the set of word-pairs
Next
Close: Sleep 1
Txt$ = "Best for this pair is now: " + Best$(Pairnum) + " by " + WinName$
Yellow: Centre Txt$, 19: White: Print
Print
Dummy$ = Chain$(Pairnum) ' create dummy Chain$ string for formatting
Dim Part$(Int(Len(Dummy$) / CPR) + 1) ' set each line to max length of Chars Per Line
Do Until Len(Dummy$) < CPR ' Do this loop until Dummy has less than CPR chars
part = part + 1
po = 70 ' set Po to 70th char of dummy chain
While Mid$(Dummy$, po, 1) <> "-": po = po + 1: Wend ' while this char is not a dash, move Po to next character
Part$(part) = Left$(Dummy$, po) ' from start to first dash after 70 becomes one part
Print Part$(part): Print ' print this part of Chain$
Dummy$ = Right$(Dummy$, Len(Dummy$) - po - 1) ' remove this part from Dummy$
Loop ' End of the loop
If Dummy$ > " " Then Print Dummy$ ' if any still left in Dummy$, print it
Play ok$
Yellow: Centre "Press a key", 34
Sleep: Run ' wait for key press, then start over
End Sub
Sub NewSet ' create new set with default data
Set1Data:
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:
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","Yellow","BROWN"
Data "CHILD","ADULT","DESERT","OASIS","QUERY","RESULT","DUNCE","GENIUS","FATHER","SON"
Set3Data:
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"
If Filename$ = "Set 1.txt" Then
Restore Set1Data ' use set 1 word pair data
ElseIf Filename$ = "Set 2.txt" Then
Restore Set2Data ' use set 2 word pair data
ElseIf Filename$ = "Set 3.txt" Then
Restore Set3Data ' use set 3 word pair data
End If
Open Filename$ For Output As #1 ' get the set's wordlist file
For a = 1 To 20
Read first$, last$ ' get the word-pair from data
Write #1, first$, last$, "21", "NOT SET", "UNSOLVED" ' write First, Last, Best, Name, and Chain to word-pair file
Next
Close
Cls: Txt$ = Filename$ + " reset": Centre Txt$, 15: Sleep 1
End Sub
Sub EggFound ' found easter egg
Sleep 1: Play ok$: Cls
Yellow: Centre "Congratulations, you found the egg!", 15: Sleep 1: Cls
For setnum = 1 To 3 ' reward: show chain of changes for each set of each pair
SetNum$ = LTrim$(Str$(setnum)) ' get a set number
Filename$ = "best" + SetNum$ + ".txt" ' set filename to this set"
Yellow: Print Filename$: White: Print: Sleep 1
Open Filename$ For Input As #1
For a = 1 To 20
Input #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a) ' get each pair's data
Yellow: Print Tab(2); First$(a); " ";: White: Print Chain$(a); " - ";: Yellow: Print Last$(a)
Next
Close
Yellow: Centre "Press a key", 36
Sleep: Cls
Next ' get the next set
Run
End Sub
Sub ShowPairs
Close
Filename$ = "Set " + SetNum$ + ".txt"
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 (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 Wipe (LN$) ' LN$ is 2-digit line nums, eg "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)) ' erase that line
Locate wl, 1: Print Space$(CPR);
Next
End Sub
Sub Centre (Txt$, LineNum) ' centre text on selected line
Ctr = Int(CPR / 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 Instructions:
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 ";: Yellow
Print "STONE";: White: Print " into ";: Yellow: Print "GOLD.": White: Print
Print " This game calls upon your skills in this art, to change a word into a totally"
Print " different one, with the least number of changes.": Print
Print " There are three sets of word-pairs provided, ranging from easy to difficult,";
Print " and you are allowed up to 20 changes for each pair. All of these can be solved"
Print " within the 20-tries limit.": Print
Print " For each change, you can ";: Yellow: Print "add";: White: Print ", ";: Yellow
Print "remove";: White: Print ", or ";: Yellow: Print "change";: White: Print " a letter, before";: Yellow
Print " re-arranging";: White: Print " them. So the length of the word may vary as you progress (to max 9 letters)."
Print " For example, we can change STONE into GOLD with just 4 changes:"
Yellow: Centre "STONE - TONE - GONE - LONG - GOLD", 18: White: Print
Print " When a word is entered, it is checked for letter-changes and word validity,"
Print " and failed words are rejected, but still count as a try.": Print
Print " A record is kept of the best score for each pair, and if you beat one of"
Print " these, your record will replace it.": Print
Print " By the way, an ";: Yellow: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
Print " word-pairs is hidden somewhere (but you may have to visit Tibet to find it)!"
Yellow: Centre "Press a key to continue", 29
Sleep: Play ok$: Cls
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/
(12-19-2025, 02:02 AM)PhilOfPerth Wrote: My last version of Alchemy had several errors in coding. This version, although probably not optimal coding, at least works as intended:
Screen _NewImage(1040, 768, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' monospace font
CPR = 1040 / _PrintWidth("X") ' 80 - Chars Per Line for centring text
_ScreenMove (_DesktopWidth - 1040) / 2, 100 '
ok$ = "o3l32ceg": bad$ = "o2l16gec" ' sound strings
WordPos = 36 ' lhs of word grid
Instructions
CheckFiles: ' check 3 word set files with history are present
For a = 1 To 3
Filename$ = "Set " + LTrim$(Str$(a)) + ".txt"
If Not _FileExists(Filename$) Then ' if any file is missing, recreate it
NewSet
txt$ = Filename$ + " reset": Centre txt$, 15
End If
Next
Cls
Chooseset: ' from 3 sets of 20 pairs, easy, medium and hard
ReDim First$(20), Last$(20), Best$(20), Name$(20), Chain$(20) ' create arrays for data of this set
Yellow: Centre "Choose from Set 1 to Set 3 (Esc TO Exit)", 15
SetNum$ = ""
While SetNum$ < "1" Or SetNum$ > "3"
SetNum$ = InKey$
Wend
Cls
ShowPairs ' display 20 word-pairs and Hi-scores for selected set
ChoosePair: ' choose a pair of words
Yellow: Centre "Choose a pair, from A to T", 29
Centre "or...", 30
Centre "Press Delete to reset this set's history ", 31 ' restore default scores for this set
Centre "Press Enter to re-choose Set Number", 32 ' choose a different set of words
Centre "Press ESC to quit", 33 ' to quit the game
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
Cls
Choice:
Select Case k ' allows Delete, Esc, a-t or A-T, or any other to re-choose set
Case Is = 21248 ' Delete - reset this word set history
Centre "Re-set the Best Results for this set (y/n)?", 20
_KeyClear: k$ = ""
While k$ = "": k$ = InKey$: Wend
Wipe "20"
If UCase$(k$) = "Y" Then NewSet ' only allow y to reset
GoTo Chooseset
Case Is = 27 ' Esc
System ' quit game
Case 65 To 84 ' A to T
Pairnum = k - 64 ' convert uppercase of letter to number 1 to 20
Case 97 To 116 ' a to t
Pairnum = k - 96 ' convert lower-case of letter to number 1 to 20
Case Else
GoTo Chooseset ' anything else, try again
End Select
SetField:
Cls: ThisChain$ = "" ' new Tries chain for this pair
Prev$ = First$(Pairnum) ' put Start word at front of chain
TryVert = 5: remain = 21: Tries = -1
Yellow: Centre First$(Pairnum), 5 ' show the first word of the pair
For a = TryVert + 1 To 25
Print Using "##"; Tab(28); a - 5; ' show try numbers
Centre String$(9, "."), a
Next ' show 9 dots for letters of each try
Centre Last$(Pairnum), 26 ' show the target word
GetTry:
Wipe "28"
Tries = Tries + 1: TryVert = TryVert + 1
k = 0
If Tries = 20 Then ' check if all tries have been used
Red: Centre "You've Used up all of your tries!", 28: _Delay 1
Sleep 1: Cls: GoTo Chooseset ' if they have, advise and restart the same pair
End If
try$ = "" ' empty Try$ ready for new word
Wipe "03": txt$ = "You have" + Str$(20 - Tries) + " tries remaining"
Yellow: Centre txt$, 3
Locate 5, 50: Print "Added"; Tab(60); "Removed"
Locate 5, 2: Print "Enter your word"
Locate 6, 2: Print "Backspace to restart try" ' restart this try
Locate 7, 2: Print "Space to restart this pair" ' restart this pair
Locate 8, 2: Print "Esc to quit"
White: Locate TryVert, WordPos - 1: Print "?"; ' show Try position
GetAKey:
k = 0
While k < 1: k = _KeyHit: Wend
Select Case k
Case Is = 13 ' Enter key pressed
If Len(try$) < 1 Then
GoTo GetAKey ' if no letters yet, ignore it
Else
GoTo Checks ' otherwise, this is a try so check changes (Checks sub)
End If
Case Is = 27 ' Esc
System ' quit the game
Case Is = 32 ' Space
GoTo SetField ' re-start this pair
Case Is = 8 ' backspace - restart this try
try$ = ""
Locate TryVert, WordPos - 2: Print " "; String$(9, "."); " " ' erase this try (may be overlength) and replace dots
GoTo GetAKey
Case 65 To 90, 97 To 122 ' A to Z or a to z pressed
try$ = try$ + UCase$(Chr$(k)) ' change to Uppercase
Locate TryVert, 35: Print " " ' remove input query
Centre try$, TryVert ' display Try$ in white
GoTo GetAKey ' back for next letter
Case Else
GoTo GetAKey ' ignore any other key
End Select
Checks: ' check word length, changes, Easter Egg,valid word, word found
CheckWordLength: ' 2 to 9 letters accepted
If Len(try$) > 9 Or Len(try$) < 2 Then
Play bad$: Red: Centre "Words 2 to 9 letters only!", 28: _Delay .5
Centre Space$(15), TryVert ' erase try (and overlaps)
try$ = "(size)" ' change Try$ to "Size" error indicator
Red: Centre try$, TryVert ' display it in red
GoTo GetTry
End If
AddedLetters: ' find letters in Try$ that were not in Prev$ (so are added)
Added = 0: added$ = ""
temp$ = Prev$ ' use Temp$ for testing to keep Prev$ intact
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, so ...
Added = Added + 1: added$ = added$ + l$ ' add to Added$ and increment Added count
Else ' but if found in temp$
Mid$(temp$, po) = " " ' change it to Space to prevent re-finding it
End If
Next
Locate TryVert, 52: Print added$ ' show all added letters
If Added > 1 Then ' if more than 1 letter added,
Play bad$: Red: Centre "Too many added - word rejected", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
Centre try$, TryVert ' change Try$ display to red,
ThisChain$ = ThisChain$ + " - " + LCase$(try$)
GoTo GetTry ' and get another try (don't change last good try)
End If
RemovedLetters: ' find letters in prev$ that are not in try$ (so are removed)
Removed = 0: removed$ = ""
temp$ = try$ ' use Temp$ for testing to keep Try$ intact
For a = 1 To Len(Prev$) '
l$ = Mid$(Prev$, a, 1) ' get a letter from Prev$,
po = InStr(temp$, l$) ' find its position in temp$, if any
If po = 0 Then ' if not in temp$, it was added, so
Removed = Removed + 1: removed$ = removed$ + l$ ' add to Added$ and increment Added count
Else ' but if found in temp$
Mid$(temp$, po) = " " ' change it to Space to prevent re-finding
End If
Next
Locate TryVert, 60: Print removed$ ' show removed letters
If Removed > 1 Then ' if more than 1 letter removed,
Play bad$: Red: Centre "Too many removed - word rejected", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
Centre try$, TryVert ' change Try$ display to red,
ThisChain$ = ThisChain$ + " - " + LCase$(try$)
GoTo GetTry ' and get another try (don't change last good try)
End If
CheckForEgg: ' check if try is the Easter Egg (number of changes is ok)
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) Then EggFound
CheckForSolved: ' check if try is the final word
If try$ = Last$(Pairnum) Then Done
CheckWord: ' check if Try$ is a legal word
Found = 0 ' set flag initially to not found
Open "R_ALL9" For Random As #1 Len = 13 ' open Random Access file
FL = LOF(1) \ 13 + 1 ' find number of words in file (may have been changed by player)
bot = 0: top = FL ' set bottom to first word, top to last
While Abs(top - bot) > 1 ' Do this while gap >1
srch = Int((top + bot) / 2) ' set the Search point at midway
Get #1, srch, A$ ' get that word as A$
Select Case A$
Case Is = try$ ' if this is Try$ (the word entered by the player)
Found = 1 ' flag Try$ as found
Exit While
Case Is < try$ ' if the word is less than try$ (earlier alphabetically)
bot = srch ' move bottom up to Srch
Case Is > try$ ' if the word is greater than try$ (earlier alphabetically)
top = srch ' move top down to Srch
End Select
Wend ' End of the While loop - repeat until Try$ is found or gap is 1
Close
If Found = 0 Then ' if Try$ was not found,
Play bad$: Red: Centre "Word not found!", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
ThisChain$ = ThisChain$ + " - " + try$
Centre try$, TryVert ' change the Try$ display colour to red,
Else
Play ok$
Prev$ = try$ ' try is good, change last good word to this one
ThisChain$ = ThisChain$ + " - " + try$ ' add separator beween tries for later display
End If
Centre try$, TryVert ' change Try$ display to appropriate colour
White
GoTo GetTry
Sub Done ' solved
Play ok$: Play ok$
Tries = Tries + 1 ' add the last try to the count
Txt$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Yellow: Centre Txt$, 30: Sleep 2: Cls
If Tries < Val(Best$(Pairnum)) Then NewRecord ' if better (lower) than the recorded Best, write in records
Run
End Sub
Sub NewRecord ' new low achieved
Centre "A new record for this pair!", 15
_KeyClear
Centre "What name would you like to use (Enter for anonymous) ", 17
Locate 17, 66: Input WinName$ ' get the player's name,
If Len(WinName$) < 2 Then WinName$ = "(ANON)" ' if no name given, use default ANON
WinName$ = UCase$(WinName$)
Wipe "17": Centre WinName$, 17
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) = First$(Pairnum) + ThisChain$ + " - " + Last$(Pairnum) ' create new record for the the Chain$ sequence
Filename$ = "Set " + SetNum$ + ".txt" ' Open Filename$ For Output As #1 ' open the history file for this set"
Open Filename$ For Output As #1
For a = 1 To 20 '
Write #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a) ' re-write the chain data for the set of word-pairs
Next
Close: Sleep 1
Txt$ = "Best for this pair is now: " + Best$(Pairnum) + " by " + WinName$
Yellow: Centre Txt$, 19: White: Print
Print
Dummy$ = Chain$(Pairnum) ' create dummy Chain$ string for formatting
Dim Part$(Int(Len(Dummy$) / CPR) + 1) ' set each line to max length of Chars Per Line
Do Until Len(Dummy$) < CPR ' Do this loop until Dummy has less than CPR chars
part = part + 1
po = 70 ' set Po to 70th char of dummy chain
While Mid$(Dummy$, po, 1) <> "-": po = po + 1: Wend ' while this char is not a dash, move Po to next character
Part$(part) = Left$(Dummy$, po) ' from start to first dash after 70 becomes one part
Print Part$(part): Print ' print this part of Chain$
Dummy$ = Right$(Dummy$, Len(Dummy$) - po - 1) ' remove this part from Dummy$
Loop ' End of the loop
If Dummy$ > " " Then Print Dummy$ ' if any still left in Dummy$, print it
Play ok$
Yellow: Centre "Press a key", 34
Sleep: Run ' wait for key press, then start over
End Sub
Sub NewSet ' create new set with default data
Set1Data:
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:
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","Yellow","BROWN"
Data "CHILD","ADULT","DESERT","OASIS","QUERY","RESULT","DUNCE","GENIUS","FATHER","SON"
Set3Data:
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"
If Filename$ = "Set 1.txt" Then
Restore Set1Data ' use set 1 word pair data
ElseIf Filename$ = "Set 2.txt" Then
Restore Set2Data ' use set 2 word pair data
ElseIf Filename$ = "Set 3.txt" Then
Restore Set3Data ' use set 3 word pair data
End If
Open Filename$ For Output As #1 ' get the set's wordlist file
For a = 1 To 20
Read first$, last$ ' get the word-pair from data
Write #1, first$, last$, "21", "NOT SET", "UNSOLVED" ' write First, Last, Best, Name, and Chain to word-pair file
Next
Close
Cls: Txt$ = Filename$ + " reset": Centre Txt$, 15: Sleep 1
End Sub
Sub EggFound ' found easter egg
Sleep 1: Play ok$: Cls
Yellow: Centre "Congratulations, you found the egg!", 15: Sleep 1: Cls
For setnum = 1 To 3 ' reward: show chain of changes for each set of each pair
SetNum$ = LTrim$(Str$(setnum)) ' get a set number
Filename$ = "best" + SetNum$ + ".txt" ' set filename to this set"
Yellow: Print Filename$: White: Print: Sleep 1
Open Filename$ For Input As #1
For a = 1 To 20
Input #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a) ' get each pair's data
Yellow: Print Tab(2); First$(a); " ";: White: Print Chain$(a); " - ";: Yellow: Print Last$(a)
Next
Close
Yellow: Centre "Press a key", 36
Sleep: Cls
Next ' get the next set
Run
End Sub
Sub ShowPairs
Close
Filename$ = "Set " + SetNum$ + ".txt"
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 (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 Wipe (LN$) ' LN$ is 2-digit line nums, eg "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)) ' erase that line
Locate wl, 1: Print Space$(CPR);
Next
End Sub
Sub Centre (Txt$, LineNum) ' centre text on selected line
Ctr = Int(CPR / 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 Instructions:
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 ";: Yellow
Print "STONE";: White: Print " into ";: Yellow: Print "GOLD.": White: Print
Print " This game calls upon your skills in this art, to change a word into a totally"
Print " different one, with the least number of changes.": Print
Print " There are three sets of word-pairs provided, ranging from easy to difficult,";
Print " and you are allowed up to 20 changes for each pair. All of these can be solved"
Print " within the 20-tries limit.": Print
Print " For each change, you can ";: Yellow: Print "add";: White: Print ", ";: Yellow
Print "remove";: White: Print ", or ";: Yellow: Print "change";: White: Print " a letter, before";: Yellow
Print " re-arranging";: White: Print " them. So the length of the word may vary as you progress (to max 9 letters)."
Print " For example, we can change STONE into GOLD with just 4 changes:"
Yellow: Centre "STONE - TONE - GONE - LONG - GOLD", 18: White: Print
Print " When a word is entered, it is checked for letter-changes and word validity,"
Print " and failed words are rejected, but still count as a try.": Print
Print " A record is kept of the best score for each pair, and if you beat one of"
Print " these, your record will replace it.": Print
Print " By the way, an ";: Yellow: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
Print " word-pairs is hidden somewhere (but you may have to visit Tibet to find it)!"
Yellow: Centre "Press a key to continue", 29
Sleep: Play ok$: Cls
End Sub
That code to me is like WOW! Its amazing how we can code things in so many ways, and its the type of code i ran from as a kid...
Question..you use SUBS and also use line labels! WHY? Line numbers and labels and also GOTO are at least to me things you should avoid but the SUBS and GOTO in one code is kinda weird!
Why not just use SUBS! Then a singular SELECT CASE...itll be fluid, easy to parse and read and MUCH easier to debug (also for kids like me, easier to understand as some of those commands are nearly as old as PETE!)
(12-19-2025, 02:02 AM)PhilOfPerth Wrote: My last version of Alchemy had several errors in coding. This version, although probably not optimal coding, at least works as intended:
Screen _NewImage(1040, 768, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' monospace font
CPR = 1040 / _PrintWidth("X") ' 80 - Chars Per Line for centring text
_ScreenMove (_DesktopWidth - 1040) / 2, 100 '
ok$ = "o3l32ceg": bad$ = "o2l16gec" ' sound strings
WordPos = 36 ' lhs of word grid
Instructions
CheckFiles: ' check 3 word set files with history are present
For a = 1 To 3
Filename$ = "Set " + LTrim$(Str$(a)) + ".txt"
If Not _FileExists(Filename$) Then ' if any file is missing, recreate it
NewSet
txt$ = Filename$ + " reset": Centre txt$, 15
End If
Next
Cls
Chooseset: ' from 3 sets of 20 pairs, easy, medium and hard
ReDim First$(20), Last$(20), Best$(20), Name$(20), Chain$(20) ' create arrays for data of this set
Yellow: Centre "Choose from Set 1 to Set 3 (Esc TO Exit)", 15
SetNum$ = ""
While SetNum$ < "1" Or SetNum$ > "3"
SetNum$ = InKey$
Wend
Cls
ShowPairs ' display 20 word-pairs and Hi-scores for selected set
ChoosePair: ' choose a pair of words
Yellow: Centre "Choose a pair, from A to T", 29
Centre "or...", 30
Centre "Press Delete to reset this set's history ", 31 ' restore default scores for this set
Centre "Press Enter to re-choose Set Number", 32 ' choose a different set of words
Centre "Press ESC to quit", 33 ' to quit the game
_KeyClear: k = 0
While k < 1: _Limit 30: k = _KeyHit: Wend
Cls
Choice:
Select Case k ' allows Delete, Esc, a-t or A-T, or any other to re-choose set
Case Is = 21248 ' Delete - reset this word set history
Centre "Re-set the Best Results for this set (y/n)?", 20
_KeyClear: k$ = ""
While k$ = "": k$ = InKey$: Wend
Wipe "20"
If UCase$(k$) = "Y" Then NewSet ' only allow y to reset
GoTo Chooseset
Case Is = 27 ' Esc
System ' quit game
Case 65 To 84 ' A to T
Pairnum = k - 64 ' convert uppercase of letter to number 1 to 20
Case 97 To 116 ' a to t
Pairnum = k - 96 ' convert lower-case of letter to number 1 to 20
Case Else
GoTo Chooseset ' anything else, try again
End Select
SetField:
Cls: ThisChain$ = "" ' new Tries chain for this pair
Prev$ = First$(Pairnum) ' put Start word at front of chain
TryVert = 5: remain = 21: Tries = -1
Yellow: Centre First$(Pairnum), 5 ' show the first word of the pair
For a = TryVert + 1 To 25
Print Using "##"; Tab(28); a - 5; ' show try numbers
Centre String$(9, "."), a
Next ' show 9 dots for letters of each try
Centre Last$(Pairnum), 26 ' show the target word
GetTry:
Wipe "28"
Tries = Tries + 1: TryVert = TryVert + 1
k = 0
If Tries = 20 Then ' check if all tries have been used
Red: Centre "You've Used up all of your tries!", 28: _Delay 1
Sleep 1: Cls: GoTo Chooseset ' if they have, advise and restart the same pair
End If
try$ = "" ' empty Try$ ready for new word
Wipe "03": txt$ = "You have" + Str$(20 - Tries) + " tries remaining"
Yellow: Centre txt$, 3
Locate 5, 50: Print "Added"; Tab(60); "Removed"
Locate 5, 2: Print "Enter your word"
Locate 6, 2: Print "Backspace to restart try" ' restart this try
Locate 7, 2: Print "Space to restart this pair" ' restart this pair
Locate 8, 2: Print "Esc to quit"
White: Locate TryVert, WordPos - 1: Print "?"; ' show Try position
GetAKey:
k = 0
While k < 1: k = _KeyHit: Wend
Select Case k
Case Is = 13 ' Enter key pressed
If Len(try$) < 1 Then
GoTo GetAKey ' if no letters yet, ignore it
Else
GoTo Checks ' otherwise, this is a try so check changes (Checks sub)
End If
Case Is = 27 ' Esc
System ' quit the game
Case Is = 32 ' Space
GoTo SetField ' re-start this pair
Case Is = 8 ' backspace - restart this try
try$ = ""
Locate TryVert, WordPos - 2: Print " "; String$(9, "."); " " ' erase this try (may be overlength) and replace dots
GoTo GetAKey
Case 65 To 90, 97 To 122 ' A to Z or a to z pressed
try$ = try$ + UCase$(Chr$(k)) ' change to Uppercase
Locate TryVert, 35: Print " " ' remove input query
Centre try$, TryVert ' display Try$ in white
GoTo GetAKey ' back for next letter
Case Else
GoTo GetAKey ' ignore any other key
End Select
Checks: ' check word length, changes, Easter Egg,valid word, word found
CheckWordLength: ' 2 to 9 letters accepted
If Len(try$) > 9 Or Len(try$) < 2 Then
Play bad$: Red: Centre "Words 2 to 9 letters only!", 28: _Delay .5
Centre Space$(15), TryVert ' erase try (and overlaps)
try$ = "(size)" ' change Try$ to "Size" error indicator
Red: Centre try$, TryVert ' display it in red
GoTo GetTry
End If
AddedLetters: ' find letters in Try$ that were not in Prev$ (so are added)
Added = 0: added$ = ""
temp$ = Prev$ ' use Temp$ for testing to keep Prev$ intact
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, so ...
Added = Added + 1: added$ = added$ + l$ ' add to Added$ and increment Added count
Else ' but if found in temp$
Mid$(temp$, po) = " " ' change it to Space to prevent re-finding it
End If
Next
Locate TryVert, 52: Print added$ ' show all added letters
If Added > 1 Then ' if more than 1 letter added,
Play bad$: Red: Centre "Too many added - word rejected", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
Centre try$, TryVert ' change Try$ display to red,
ThisChain$ = ThisChain$ + " - " + LCase$(try$)
GoTo GetTry ' and get another try (don't change last good try)
End If
RemovedLetters: ' find letters in prev$ that are not in try$ (so are removed)
Removed = 0: removed$ = ""
temp$ = try$ ' use Temp$ for testing to keep Try$ intact
For a = 1 To Len(Prev$) '
l$ = Mid$(Prev$, a, 1) ' get a letter from Prev$,
po = InStr(temp$, l$) ' find its position in temp$, if any
If po = 0 Then ' if not in temp$, it was added, so
Removed = Removed + 1: removed$ = removed$ + l$ ' add to Added$ and increment Added count
Else ' but if found in temp$
Mid$(temp$, po) = " " ' change it to Space to prevent re-finding
End If
Next
Locate TryVert, 60: Print removed$ ' show removed letters
If Removed > 1 Then ' if more than 1 letter removed,
Play bad$: Red: Centre "Too many removed - word rejected", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
Centre try$, TryVert ' change Try$ display to red,
ThisChain$ = ThisChain$ + " - " + LCase$(try$)
GoTo GetTry ' and get another try (don't change last good try)
End If
CheckForEgg: ' check if try is the Easter Egg (number of changes is ok)
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) Then EggFound
CheckForSolved: ' check if try is the final word
If try$ = Last$(Pairnum) Then Done
CheckWord: ' check if Try$ is a legal word
Found = 0 ' set flag initially to not found
Open "R_ALL9" For Random As #1 Len = 13 ' open Random Access file
FL = LOF(1) \ 13 + 1 ' find number of words in file (may have been changed by player)
bot = 0: top = FL ' set bottom to first word, top to last
While Abs(top - bot) > 1 ' Do this while gap >1
srch = Int((top + bot) / 2) ' set the Search point at midway
Get #1, srch, A$ ' get that word as A$
Select Case A$
Case Is = try$ ' if this is Try$ (the word entered by the player)
Found = 1 ' flag Try$ as found
Exit While
Case Is < try$ ' if the word is less than try$ (earlier alphabetically)
bot = srch ' move bottom up to Srch
Case Is > try$ ' if the word is greater than try$ (earlier alphabetically)
top = srch ' move top down to Srch
End Select
Wend ' End of the While loop - repeat until Try$ is found or gap is 1
Close
If Found = 0 Then ' if Try$ was not found,
Play bad$: Red: Centre "Word not found!", 28: _Delay 1 ' advise this in red,
try$ = LCase$(try$)
ThisChain$ = ThisChain$ + " - " + try$
Centre try$, TryVert ' change the Try$ display colour to red,
Else
Play ok$
Prev$ = try$ ' try is good, change last good word to this one
ThisChain$ = ThisChain$ + " - " + try$ ' add separator beween tries for later display
End If
Centre try$, TryVert ' change Try$ display to appropriate colour
White
GoTo GetTry
Sub Done ' solved
Play ok$: Play ok$
Tries = Tries + 1 ' add the last try to the count
Txt$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Yellow: Centre Txt$, 30: Sleep 2: Cls
If Tries < Val(Best$(Pairnum)) Then NewRecord ' if better (lower) than the recorded Best, write in records
Run
End Sub
Sub NewRecord ' new low achieved
Centre "A new record for this pair!", 15
_KeyClear
Centre "What name would you like to use (Enter for anonymous) ", 17
Locate 17, 66: Input WinName$ ' get the player's name,
If Len(WinName$) < 2 Then WinName$ = "(ANON)" ' if no name given, use default ANON
WinName$ = UCase$(WinName$)
Wipe "17": Centre WinName$, 17
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) = First$(Pairnum) + ThisChain$ + " - " + Last$(Pairnum) ' create new record for the the Chain$ sequence
Filename$ = "Set " + SetNum$ + ".txt" ' Open Filename$ For Output As #1 ' open the history file for this set"
Open Filename$ For Output As #1
For a = 1 To 20 '
Write #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a) ' re-write the chain data for the set of word-pairs
Next
Close: Sleep 1
Txt$ = "Best for this pair is now: " + Best$(Pairnum) + " by " + WinName$
Yellow: Centre Txt$, 19: White: Print
Print
Dummy$ = Chain$(Pairnum) ' create dummy Chain$ string for formatting
Dim Part$(Int(Len(Dummy$) / CPR) + 1) ' set each line to max length of Chars Per Line
Do Until Len(Dummy$) < CPR ' Do this loop until Dummy has less than CPR chars
part = part + 1
po = 70 ' set Po to 70th char of dummy chain
While Mid$(Dummy$, po, 1) <> "-": po = po + 1: Wend ' while this char is not a dash, move Po to next character
Part$(part) = Left$(Dummy$, po) ' from start to first dash after 70 becomes one part
Print Part$(part): Print ' print this part of Chain$
Dummy$ = Right$(Dummy$, Len(Dummy$) - po - 1) ' remove this part from Dummy$
Loop ' End of the loop
If Dummy$ > " " Then Print Dummy$ ' if any still left in Dummy$, print it
Play ok$
Yellow: Centre "Press a key", 34
Sleep: Run ' wait for key press, then start over
End Sub
Sub NewSet ' create new set with default data
Set1Data:
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:
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","Yellow","BROWN"
Data "CHILD","ADULT","DESERT","OASIS","QUERY","RESULT","DUNCE","GENIUS","FATHER","SON"
Set3Data:
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"
If Filename$ = "Set 1.txt" Then
Restore Set1Data ' use set 1 word pair data
ElseIf Filename$ = "Set 2.txt" Then
Restore Set2Data ' use set 2 word pair data
ElseIf Filename$ = "Set 3.txt" Then
Restore Set3Data ' use set 3 word pair data
End If
Open Filename$ For Output As #1 ' get the set's wordlist file
For a = 1 To 20
Read first$, last$ ' get the word-pair from data
Write #1, first$, last$, "21", "NOT SET", "UNSOLVED" ' write First, Last, Best, Name, and Chain to word-pair file
Next
Close
Cls: Txt$ = Filename$ + " reset": Centre Txt$, 15: Sleep 1
End Sub
Sub EggFound ' found easter egg
Sleep 1: Play ok$: Cls
Yellow: Centre "Congratulations, you found the egg!", 15: Sleep 1: Cls
For setnum = 1 To 3 ' reward: show chain of changes for each set of each pair
SetNum$ = LTrim$(Str$(setnum)) ' get a set number
Filename$ = "best" + SetNum$ + ".txt" ' set filename to this set"
Yellow: Print Filename$: White: Print: Sleep 1
Open Filename$ For Input As #1
For a = 1 To 20
Input #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a) ' get each pair's data
Yellow: Print Tab(2); First$(a); " ";: White: Print Chain$(a); " - ";: Yellow: Print Last$(a)
Next
Close
Yellow: Centre "Press a key", 36
Sleep: Cls
Next ' get the next set
Run
End Sub
Sub ShowPairs
Close
Filename$ = "Set " + SetNum$ + ".txt"
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 (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 Wipe (LN$) ' LN$ is 2-digit line nums, eg "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)) ' erase that line
Locate wl, 1: Print Space$(CPR);
Next
End Sub
Sub Centre (Txt$, LineNum) ' centre text on selected line
Ctr = Int(CPR / 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 Instructions:
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 ";: Yellow
Print "STONE";: White: Print " into ";: Yellow: Print "GOLD.": White: Print
Print " This game calls upon your skills in this art, to change a word into a totally"
Print " different one, with the least number of changes.": Print
Print " There are three sets of word-pairs provided, ranging from easy to difficult,";
Print " and you are allowed up to 20 changes for each pair. All of these can be solved"
Print " within the 20-tries limit.": Print
Print " For each change, you can ";: Yellow: Print "add";: White: Print ", ";: Yellow
Print "remove";: White: Print ", or ";: Yellow: Print "change";: White: Print " a letter, before";: Yellow
Print " re-arranging";: White: Print " them. So the length of the word may vary as you progress (to max 9 letters)."
Print " For example, we can change STONE into GOLD with just 4 changes:"
Yellow: Centre "STONE - TONE - GONE - LONG - GOLD", 18: White: Print
Print " When a word is entered, it is checked for letter-changes and word validity,"
Print " and failed words are rejected, but still count as a try.": Print
Print " A record is kept of the best score for each pair, and if you beat one of"
Print " these, your record will replace it.": Print
Print " By the way, an ";: Yellow: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
Print " word-pairs is hidden somewhere (but you may have to visit Tibet to find it)!"
Yellow: Centre "Press a key to continue", 29
Sleep: Play ok$: Cls
End Sub
That code to me is like WOW! Its amazing how we can code things in so many ways, and its the type of code i ran from as a kid...
Question..you use SUBS and also use line labels! WHY? Line numbers and labels and also GOTO are at least to me things you should avoid but the SUBS and GOTO in one code is kinda weird!
Why not just use SUBS! Then a singular SELECT CASE...itll be fluid, easy to parse and read and MUCH easier to debug (also for kids like me, easier to understand as some of those commands are nearly as old as PETE!)
John
Hi John. Thanks for the feedback. I guess I should put some more of the Main into subs; it's just the way it evolved in my head at the time.
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/
I love that it never goes more than 2 layers deep! Linus (the man who made linux and GitHub) would be pleased!
Now, forgive me for being dictatorish but
CONST CLR_RED& = _RGB32(255,0,255) ' //etc with yellow black ....
Then ONE sub can handle it all by you sending the const
SUB Set_Color (CLRFlag&)
AND joyously you can then stick it in a .bi (consts) and a .bm (the sub) and use it in any programme in the future and by adding more consts you can have as many colours as you want!
(12-19-2025, 10:27 PM)Unseen Machine Wrote: I love that it never goes more than 2 layers deep! Linus (the man who made linux and GitHub) would be pleased!
Now, forgive me for being dictatorish but
CONST CLR_RED& = _RGB32(255,0,255) ' //etc with yellow black ....
Then ONE sub can handle it all by you sending the const
SUB Set_Color (CLRFlag&)
AND joyously you can then stick it in a .bi (consts) and a .bm (the sub) and use it in any programme in the future and by adding more consts you can have as many colours as you want!
John
Your solution seems like a lot more work to me, John.
I'm personally a lazy coder, and have bad knuckles. Conserving keystrokes is important to me to reduce stress on my joints. Too much stretching and typing and clicking, and it's time for me to take a break, take something for inflammation, and come back later.
This is the original:
Code: (Select All)
Print " By the way, an ";: Yellow: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
And with your solution, this same code would be:
Code: (Select All)
Print " By the way, an ";: Set_Color Yellow: Print "Easter Egg";: Set_Color White: Print " with the best recorded solutions for all of the"
That's a good bit of unnecessary extra typing there. In a program with a crap load of color changes, used as this is intended to be used? I'd just do like this -- define a quick sub with the chosen color and have it set it, and be done with it.
Added bonus? No need for a *.bi or *.bm file. You can share the entire code, as is, on the forums for others to test, without needing to download anything, copy/paste from download folders, clean up stray *.bm files afterwards... Just one code box, all the code inside, and done.
PS: You don't need to define a ton of colors usually. You do know we have a $COLOR metacommand now, that loads a whole boatload of predefined color definitions directly for use? If you know the HTML color names, you'll already know most of them. Last count was.... over 250ish? 260ish? I think?
(12-19-2025, 10:27 PM)Unseen Machine Wrote: I love that it never goes more than 2 layers deep! Linus (the man who made linux and GitHub) would be pleased!
Now, forgive me for being dictatorish but
CONST CLR_RED& = _RGB32(255,0,255) ' //etc with yellow black ....
Then ONE sub can handle it all by you sending the const
SUB Set_Color (CLRFlag&)
AND joyously you can then stick it in a .bi (consts) and a .bm (the sub) and use it in any programme in the future and by adding more consts you can have as many colours as you want!
John
Your solution seems like a lot more work to me, John.
I'm personally a lazy coder, and have bad knuckles. Conserving keystrokes is important to me to reduce stress on my joints. Too much stretching and typing and clicking, and it's time for me to take a break, take something for inflammation, and come back later.
This is the original:
Code: (Select All)
Print " By the way, an ";: Yellow: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
And with your solution, this same code would be:
Code: (Select All)
Print " By the way, an ";: Set_Color Yellow: Print "Easter Egg";: Set_Color White: Print " with the best recorded solutions for all of the"
That's a good bit of unnecessary extra typing there. In a program with a crap load of color changes, used as this is intended to be used? I'd just do like this -- define a quick sub with the chosen color and have it set it, and be done with it.
Added bonus? No need for a *.bi or *.bm file. You can share the entire code, as is, on the forums for others to test, without needing to download anything, copy/paste from download folders, clean up stray *.bm files afterwards... Just one code box, all the code inside, and done.
PS: You don't need to define a ton of colors usually. You do know we have a $COLOR metacommand now, that loads a whole boatload of predefined color definitions directly for use? If you know the HTML color names, you'll already know most of them. Last count was.... over 250ish? 260ish? I think?
Thanks both; lots for me to think about. As someone once said, there's more than one way to flay a feline.
@ Steve "In a program with a crap load of color changes, used as this is intended to be used? I'd just do like this -- define a quick sub with the chosen color and have it set it, and be done with it." Isn't that what I've done?
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/
(12-19-2025, 10:27 PM)Unseen Machine Wrote: I love that it never goes more than 2 layers deep! Linus (the man who made linux and GitHub) would be pleased!
Now, forgive me for being dictatorish but
CONST CLR_RED& = _RGB32(255,0,255) ' //etc with yellow black ....
Then ONE sub can handle it all by you sending the const
SUB Set_Color (CLRFlag&)
AND joyously you can then stick it in a .bi (consts) and a .bm (the sub) and use it in any programme in the future and by adding more consts you can have as many colours as you want!
John
Your solution seems like a lot more work to me, John.
I'm personally a lazy coder, and have bad knuckles. Conserving keystrokes is important to me to reduce stress on my joints. Too much stretching and typing and clicking, and it's time for me to take a break, take something for inflammation, and come back later.
This is the original:
Code: (Select All)
Print " By the way, an ";: Yellow: Print "Easter Egg";: White: Print " with the best recorded solutions for all of the"
And with your solution, this same code would be:
Code: (Select All)
Print " By the way, an ";: Set_Color Yellow: Print "Easter Egg";: Set_Color White: Print " with the best recorded solutions for all of the"
That's a good bit of unnecessary extra typing there. In a program with a crap load of color changes, used as this is intended to be used? I'd just do like this -- define a quick sub with the chosen color and have it set it, and be done with it.
Added bonus? No need for a *.bi or *.bm file. You can share the entire code, as is, on the forums for others to test, without needing to download anything, copy/paste from download folders, clean up stray *.bm files afterwards... Just one code box, all the code inside, and done.
PS: You don't need to define a ton of colors usually. You do know we have a $COLOR metacommand now, that loads a whole boatload of predefined color definitions directly for use? If you know the HTML color names, you'll already know most of them. Last count was.... over 250ish? 260ish? I think?
Yes, but it was quick reply and i see now i was not wrong but not right!
(12-20-2025, 02:09 AM)PhilOfPerth Wrote: Thanks both; lots for me to think about. As someone once said, there's more than one way to flay a feline.
@ Steve "In a program with a crap load of color changes, used as this is intended to be used? I'd just do like this -- define a quick sub with the chosen color and have it set it, and be done with it." Isn't that what I've done?
That's exactly what you've done, and I was just saying, "I'd do it the exact same way."
Everyone has their own Style, and there's nothing wrong with John's. It's just not the style I'd use at all, as I try to minimize typing as much as often. I'd rather just do it the way you did it originally than add in extra typing and do it the way he suggested. I'm a lazy programmer.
(12-20-2025, 10:51 PM)Unseen Machine Wrote: Yes, but it was quick reply and i see now i was not wrong but not right!
Me
Actually, I think you might want to take a step back and rethink yourself here. This is once case where you're absolutely reinvening the wheel and making it more complex than the original.
Let's take a second to fully flesh out your design
Code: (Select All)
SUB Set_Color (CLRFlag&)
COLOR CLRFlag&
END SUB
Now... explain to me how that's any better than just doing the standard process itself as:
Code: (Select All)
COLOR CLRFlag&
Having a set of predefined CONST values for your colors are fine ($COLOR:32 loads a list for us like that). But then, if you're defining your color constants, *why* would you need a Set_Color sub to.... simply call the COLOR command?
You're putting an extra layer of unnecessary abstraction in there. I don't disagree with the concept of CONST color values (which is why I added all those $COLOR:32 values into the language for us), but in this case, it doesn't seem you've thought your idea out fully. If you have the CONST names, you don't need a Set_Color sub; you just use the COLOR colorName.
Which still wouldn't replicate what this short-cut is doing: It's taking out the need for COLOR name, and just making it a simple name command.
Instead of: COLOR Yellow
It's just: Yellow
So... yeah... I think when you flesh out your concept fully here, you're going in the wrong direction. Instead of making a command simpler as he has, you're just making it more complex instead. To me, that's the wrong direction to be working in.
