12-17-2025, 05:12 AM
(This post was last modified: 12-17-2025, 05:13 AM by PhilOfPerth.)
I've just dicovered this sub-forum, created some time ago. I guess I should use it! 
Not sure what I should do, but I'll post a few of my games, which have already been posted but have changed somewhat since then.
This is the latest version of Alchemy, a word game that requires only word-skills. The rules are presented in the game.
Not sure what I should do, but I'll post a few of my games, which have already been posted but have changed somewhat since then.
This is the latest version of Alchemy, a word game that requires only word-skills. The rules are presented in the game.
Code: (Select All)
Common Shared SetNum$, CPR, bad$, ok$, Pairnum, First$(), Last$(), Best$(), Name$(), Chain$(), Name$, ThisChain$, Tries, Filename$, Part$()
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/
Please visit my Website at: http://oldendayskids.blogspot.com/
