+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Games (https://qb64phoenix.com/forum/forumdisplay.php?fid=57)
+---- Thread: New features in Alchemy (/showthread.php?tid=2476)
New features in Alchemy - PhilOfPerth - 03-02-2024
NAlchemy now has three sets of 20 word-pairs, graded by difficulty level, to choose from.
Any (or all) of the sets can be erased and replaced with your own word preferences.
The dictionary is contained in one random-access file, with almost instant response time. (@ bplus thanks for help on this).
Best scores for each word-pair are kept for each session. Sessions can be paused and continued at another time, or restarted.
A Best-Ever list is kept, with the chains of changes for each. These can also be removed and re-started at will.
An “Easter-Egg” allows a (brief) sneak peek at these chains.
Code: (Select All)
Common Shared Added, Added$, Removed, Removed$, Ln$, SetNum$, SetNum, Filename$, RealWord, LineNum, CPL, WordPos, k, bad$, ok$, a$
Common Shared Pairnum, Prev$, First$(), Last$(), current$(), Name$(), bestever$(), Chain$(), Target$(), Target$, Name$, chain$, TryVert, Try$, Tries, MaxTries
Randomize Timer
ok$ = "o3l32gc": bad$ = "o2l16cg"
ScreenSetup:
Screen _NewImage(1120, 820, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 24, "monospace"): _Font f&
lhs = (_DesktopWidth - 1120) / 2
_ScreenMove lhs, 86 ' centre display on screen
CPL = 1120 / _PrintWidth("X")
Set1Data:
Data "BADGE","MEDAL","HORSE","SHEEP","SHED","HOUSE","CAR","TRUCK","COLD","HOT"
Data "MAJOR","MINOR","PASS","FAIL","STEAK","EGGS","SUN","MOON","LOCK","WATCH"
Data "CUP","PLATE","PARK","GARDEN","RIPE","ROTTEN","SHORT","TALL","WAR","PEACE"
Data "BIG","SMALL","BOOK","PAPER","DRAIN","SEWER","DRESS","SUIT","GREEN","BROWN"
Set2Data:
Data "LOOK","LISTEN","MILK","HONEY","SPICE","SUGAR","TOWN","CITY","WEED","FLOWER"
Data "BIRD","FISH","BLUNT","SHARP","BOX","CARTON","CHILD","ADULT","COPPER","BRASS"
Data "CREAM","CUSTARD","DANGER","SAFETY","FOX","HOUND","HOUR","MINUTE","LION","TIGER"
Data "RAKE","SHOVEL","WOOL","COTTON","ANVIL","HAMMER","BLACK","WHITE","DESERT","OASIS"
Set3Data:
Data "DUNCE","GENIUS","FATHER","SON","PAPER","PENCIL","PRETTY","UGLY","RAISE","LOWER"
Data "ROAD","STREET","FORWARD","REVERSE","MARS","SATURN","MODEST","PROUD","DARK","LIGHT"
Data "FRINGE","PLAIT","EASTER","EGG","MARRY","DIVORCE","BEDROOM","KITCHEN","ANTIQUE","VINTAGE"
Data "COVER","EXPOSE","PATTERN","MODEL","DUCKLING","SWAN","RUBY","DIAMOND","CIRCLE","SQUARE"
'Wipeout ' (this sub will delete all 3 sets, **including** historic best scores - don't use it unless you have new word-pairs)
Description
Dim Set$(3, 20, 6) ' 3 Set files will hold First, Last, Current, Name, BestEver, and Chain for 20 pairs
CheckFiles: ' 3 Set files are checked and if any is not found, that Set file is created with 6 defaults.
For a = 1 To 3
Filename$ = "set" + LTrim$(Str$(a))
If Not _FileExists(Filename$) Then
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 first$, last$
Write #1, first$, last$, "21", "NOT SET", "21", ""
Next
Close
End If
Next
ChooseSet:
_KeyClear
Cls
Centre "Choose from Set 1 to Set 3 (9 TO EXIT)", 15
GetSetNum:
SetNum$ = InKey$
_Limit 30
If SetNum$ = "9" Then System
If SetNum$ < "1" Or SetNum$ > "3" Then GoTo GetSetNum
SetNum = Val(SetNum$)
WIPE "15"
LoadSet:
ReDim First$(20), Last$(20), current$(20), Name$(20), bestever$(20), Chain$(20)
Filename$ = "set" + SetNum$
Open Filename$ For Input As #1
For a = 1 To 20
Input #1, First$(a), Last$(a), current$(a), Name$(a), bestever$(a), Chain$(a)
Next
Close
OptionRefresh: ' invite replacing set and chains data for this set only with defaults
_KeyClear: k = 0
yellow: Centre " Would you like to reset the current best scores for this set (y/n)", 30
GetYesNo:
While k < 1
_Limit 30
k = _KeyHit
Wend
WIPE "30"
If k = 89 Or k = 121 Then ' Y or y
If SetNum = 1 Then
Restore Set1Data
ElseIf SetNum = 2 Then
Restore Set2Data
Else
Restore Set3Data
End If
Open Filename$ For Output As #1
For a = 1 To 20
Read first$, last$
Write #1, first$, last$, "21", "NOT SET", "21", ""
Next
Close
msg$ = Filename$ + " reset"
Centre msg$, 15
End If
GameSetup:
MaxTries = 20: WordPos = 36
ShowPairs ' and now go back and re-load the pairs.
ChoosePair: ' choose a pair of words to attempt
yellow: Centre "Choose a pair, from A to T", 29
Centre "(ESC to quit)", 30 ' Esc quits the game
Centre "Z to re-choose set number", 31 ' choose pair Z to change set number
choose:
_KeyClear: k = 0
While k < 1
_Limit 30
k = _KeyHit
Wend
Select Case k
Case Is = 90, 122 ' Z or z
GoTo ChooseSet ' re-choose set
Case Is = 27 ' Esc to quit
System
Case 65 To 84 ' A to T
Pairnum = k - 64 ' convert to number 1 to 20
Case 97 To 116 ' a to t
Pairnum = k - 96 ' convert to number 1 to 20
Case Else ' if it's none of these, try again
Play bad$
GoTo choose
End Select
FirstLook:
chain$ = "" ' empty the chain for this pair
Prev$ = First$(Pairnum) ' put start word at front of chain
Cls
TryVert = 6 ' row 7 will take the first try
remain = 21: Tries = 0 ' start each game with 21 tries remaining
target = Val(current$(Pairnum)): Name$ = Name$(Pairnum) ' get existing details of selected pair
msg$ = "Target:" + Str$(target)
Centre msg$, 4 ' show target for this pair
yellow: Centre First$(Pairnum), 5 ' show the first word
For a = TryVert To MaxTries + 5
Print Tab(30); a - 5;
Centre String$(9, "."), a
Next ' show 9 dots for each try
yellow: Centre Last$(Pairnum), 26 ' show the last word at bottom
_KeyClear
CheckNumTries:
If Tries = MaxTries Then ' check if all tries used yet
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
Else ' but if not all used,
Locate TryVert, WordPos: Print String$(9, "."); Tab(56); Space$(30) ' clear area for added and removed letters,
yellow:
WIPE "30"
txt$ = "You have" + Str$(20 - Tries) + " tries remaining"
Centre txt$, 30 ' and advise of remaining tries and go on
End If
Sleep
GetTry:
yellow
Locate 5, 50: Print "Added"; Tab(60); "Removed"
For a = 0 To 2
Locate 5 + a, 5: Print Space$(21)
Next
Sleep 2
Locate 5, 8: Print "Enter your word" ' show options
Print Tab(5); "Space to restart pair"
Print Tab(10); "Esc to quit"
white
Locate TryVert, WordPos - 2
Input Try$ ' show cursor outside try-line with try position on first dot
Try$ = UCase$(Try$)
Select Case Try$
Case Is = Chr$(27) ' Esc to quit
System
Case Is = Chr$(32) ' space to restart from try 1
GoTo FirstLook
Case Is < "A", Is > "z" ' not a letter
Play bad$: GoTo GetTry
Case Else
If Len(Try$) < 2 Or Len(Try$) > 9 Then ' accept lengths 2 to 9 letters only
Play bad$
red: Centre "Words from 2 to 9 letters only allowed", 29
Sleep 1: WIPE "29": white
Locate TryVert, WordPos
Print String$(9, "."); " " ' if try length is wrong, erase and start this try again
GoTo GetTry
End If
End Select
Letters:
Tries = Tries + 1
Locate TryVert, WordPos: Print Space$(12)
Centre Try$, TryVert
CheckWord ' Call Sub to Check the Player's Word
white
Locate TryVert, 4: Print Space$(31)
TryVert = TryVert + 1
GoTo GetTry
' ------------------------------------------------------------------- subs below -------------------------------------------------------------------
Sub ShowPairs
Filename$ = "set" + LTrim$(Str$(SetNum))
Open Filename$ For Input As #1
For a = 1 To 20
Input #1, First$(a), Last$(a), current$(a), Name$(a), bestever$(a), Chain$(a)
Next
Close
yellow: Centre "Word Pairs", 6 ' show pair details, but don't show chains
Print Tab(18); "Pair"; Tab(26); "From"; Tab(37); "To"; Tab(44); "Best"; Tab(54); "By"
white
For a = 1 To 20
Print Tab(19); Chr$(a + 64); Tab(26); First$(a); Tab(36); Last$(a); Tab(45); current$(a); Tab(54); Name$(a);
Next
Close
Play ok$
End Sub
Sub CheckWord ' check this word - number of changes ok? valid word?
Added = 0: Added$ = "": Removed = 0: Removed$ = "": result = 1
'look for new letters
CountAddedLetters: ' Find letters in Try$ that were not in Prev$ (so they are added)
temp$ = Prev$ ' keep prev$ intact while 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...
Added = Added + 1: Added$ = Added$ + l$ ' so add to Added$ and increment Added count
Else ' but if in temp$, replace in temp$ with a space to pevent double-find
temp$ = Left$(temp$, po - 1) + " " + Right$(temp$, Len(temp$) - po)
End If
Next
CountRemovedLetters: ' Find letters in prev$ that are not in try$ (so they were removed)
temp$ = Try$ ' keep try$ intact while 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 try$ it has been removed
Removed = Removed + 1: Removed$ = Removed$ + l$ ' so add to Rmoved$$ and increment Removed count
Else ' but if in temp$, replace in temp$ with a space to pevent double-find
temp$ = Left$(temp$, po - 1) + " " + Right$(temp$, Len(temp$) - po)
End If
Next
ResultOfCount: ' check number of added and removed letters
If Added > 1 Or Removed > 1 Then
result = 0 ' too many added or removed letters
WIPE "30"
red: Centre "Too many changes!", 30
GoTo ChecksFinished ' result = 0 means failed changes test, so skip further checks
End If
CheckIfLastFound:
If Try$ = Last$(Pairnum) Then ' changes were ok, so if this try matches the last word, we're finished
result = 2
GoTo ChecksFinished
End If
CheckDictionary: ' changes ok, but it's not the final word so check if it's a valid word
result = 0
If Not _FileExists("RA.txt") Then
Print "Creating RA file": Sleep 1: MakeRA
End If
Open "RA.txt" For Random As #1 Len = 11
fl = LOF(1) \ 11 + 1 ' number of words in file
bot = 0: top = fl
While Abs(top - bot) > 1
srch = Int((top + bot) / 2)
Get #1, srch, a$
a$ = UCase$(a$)
If a$ = Try$ Then result = 1: Exit While
If a$ < Try$ Then ' too low
bot = srch
Else
top = srch
End If
Wend
Close
ChecksFinished: ' result: 0 = , 1 = , 2 = last word found
Select Case result
Case Is = 0 ' not a word
red: Centre "Word failed!", 31
Centre Try$, TryVert
chain$ = chain$ + " " + String$(Len(Try$), "*") + " - "
Play bad$
Case Is = 1 ' word is legit but not last word
yellow: Centre "Word ok", 31
Centre Try$, TryVert
If Len(chain$) Mod (70) = 1 Then chain$ = chain$ + Chr$(13)
chain$ = chain$ + Try$ + " - "
Play ok$
Prev$ = Try$
Case Is = 2 ' last word is found
msg$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
yellow: Centre msg$, 31
Centre Try$, TryVert
If Len(chain$) Mod (70) = 0 Then chain$ = chain$ + Chr$(13) ' tidy up the display of long chains
chain$ = First$(Pairnum) + " - " + chain$ + Try$ ' complete the chain
FinishedPair
End Select
Locate TryVert, 50: Print Added$; Tab(60); Removed$
Sleep 1
WIPE "3031"
End Sub
Sub FinishedPair
Play ok$: Play ok$: Cls: yellow
msg$ = "You did it in " + LTrim$(Str$(Tries)) + " changes"
Centre msg$, 15
If Tries < Val(current$(Pairnum)) Then ' if this beats the BestEver for the current round,
Centre "New record! Enter your name (or <ENTER> for anonymous) ", 16
Locate 16, 66: Input winname$ ' get the player's name,
If Len(winname$) < 2 Then winname$ = "(ANON)" ' if <ENTER> (or only one character) is given, player is anonymous
Name$(Pairnum) = UCase$(winname$) ' update the name of best player in current round for this pair
current$(Pairnum) = LTrim$(Str$(Tries)) ' update the best score in the current round for this set
If Tries < Val(bestever$(Pairnum)) Then Chain$(Pairnum) = chain$ ' if it beats best ever, update chain$ for this pair
Filename$ = "set" + SetNum$
Open Filename$ For Output As #1 ' and write the new records to file
Cls
For a = 1 To 20 '
Write #1, First$(a), Last$(a), current$(a), Name$(a)
Write #1, bestever$(a), Chain$(a)
Next
Close
End If
Cls
yellow
msg$ = "Best for this pair: " + current$(Pairnum) + " by " + Name$(Pairnum)
Centre msg$, 15
white: Locate 16, 1: Print chain$
Play ok$
yellow: Centre "Press a key", 19
If Try$ = "EGG" Then EasterEgg: Sleep ' Easter surprise
Sleep
Run
End Sub
Sub WIPE (ln$)
If Len(ln$) = 1 Then ln$ = "0" + ln$ ' catch single-digit line numbers
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2))
Locate wl, 1: Print Space$(100)
Next
End Sub
Sub MakeRA
' creates a Random Access file RA.txt with words to 9 chars length, from words.txt, which has words to 15 chars length
' to create to max length x, change len to Len = x+2
If _FileExists("RA.txt") Then Kill "RA.txt"
Open "words.txt" For Input As #1
Open "RA.txt" For Random As #2 Len = 11
While Not EOF(1)
Input #1, wrd$
If Len(wrd$) < 10 Then
a = a + 1
Put #2, a, wrd$
Print a
End If
Wend
End Sub
Sub Centre (txt$, linenum)
ctr = Int(CPL / 2 - Len(txt$) / 2) + 1
Locate linenum, ctr
Print txt$
End Sub
Sub red
Color _RGB(255, 0, 0)
End Sub
Sub white
Color _RGB(255, 255, 255)
End Sub
Sub yellow
Color _RGB(255, 255, 0)
End Sub
Sub green
Color _RGB(0, 255, 0)
End Sub
Sub Description
AlchemyDescription:
yellow: Centre "ALCHEMY", 2: white: Print
Print " Alchemy (al/ke/mi) can be defined as the process of changing something into"
Print " something different in a mystical way, such as changing ";: green
Print "STONE";: white: Print " into ";: green: Print "GOLD.": white: Print
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 target word is produced.": Print
Print " But in Alchemy you have another tool available to you for the transformation."
Print " You can also ";: green: Print "add";: white: Print " or ";: green
Print "remove";: white: Print " a letter, before";: green
Print " re-arranging";: white: Print " them, so the word"
Print " may change in length several times as you progress (min 2, max 9 letters).": Print
Print " As an example, we can change STONE into GOLD with just 4 changes:"
green: Centre "STONE - TONE - GONE - LONG - GOLD", 18: white: Print
Print " You are allowed up to 20 changes, and a record is kept of the best score for"
Print " each pair (you can restart these records at any time).": Print
Print " There are three sets of word-pairs to choose from, and their solutions are"
Print " progressively harder with each set.": Print
yellow: Centre "Press a key to continue", 29
Sleep: Play ok$: Cls
End Sub
Sub Wipeout
' will re-create ALL set files!
If _FileExists("set1") Then Kill "set1"
If _FileExists("set2") Then Kill "set2"
If _FileExists("set3") Then Kill "set3"
End Sub
Sub EasterEgg ' nothing to see here!
Cls: Close
Centre "Congratulations, you've found the Easter Egg!", 2
Centre "Here are some possible solutions for all word-pairs", 3
Print
For set = 1 To 3
Filename$ = "Set" + LTrim$(Str$(set))
yellow: Centre msg$, 4: white
Open Filename$ For Input As #1
For a = 1 To 20
Input #1, x$, x$, x$, x$, x$, chain$
Print Tab(2); chain$;
Next
Close: Sleep 3: Cls
Next
End Sub