11-21-2022, 05:54 AM
To those of you who helped with my previous feeble attempt at this programme, thank you!
Alchemy has been completely re-worked and has a few extra features:
Alchemy has been completely re-worked and has a few extra features:
- The previous best train of changes for each pair can be viewed.
- Selection of a pair is simplified
- An additional set of word-pairs can be substituted by "commenting out" the first two data lines.
- All files are now correctly attached as a .zip file and can be extracted to the Alchemy folder.
Code: (Select All)
Screen 9
_FullScreen
Clear
DefInt A-Z
Common Shared try$, fail, tries, prev$, tryvert, targets(), target, firstwords$(), first$, lastwords$(), last$, pairnumber$, pairnumber, names$(), name$, ok$, fail$, temp$
Common Shared added$, removed$, ln$, train$()
maxtries = 20: minsize = 2: ok$ = "o3l32cego4c": fail$ = "o2l16co1gec"
Dim firstwords$(20), lastwords$(20), targets(20), names$(20), train$(20)
Randomize Timer
Data "BIG","SMALL","LION","TIGER","CAR","TRUCK","BLACK","WHITE","WEED","FLOWER","BEDROOM","KITCHEN","COPPER","BRASS","DESERT","OASIS","MILK","HONEY","HORSE","SHEEP"
Data "BADGE","MEDAL","MARRY","DIVORCE","SHED","HOUSE","WAR","PEACE","SUIT","DRESS","BOX","CARTON","ROAD","STREET","DUNCE","GENIUS","CUP","PLATE","STEAK","EGGS"
Data "ORB","SCEPTRE","TOWN","VILLAGE","BURGER","CHIPS","YOUTH","MAIDEN","OLD","NEW","FAKE","GENUINE","TEA","COFFEE","DRESS","SKIRT","PLANTS","WEEDS","PENCIL","CRAYON"
Data "GLASS","BEAKER","GUITAR","PIANO","SLATE","STONE","CORD","ROPE","JUNGLE","DESERT","PANTRY","CUPBOARD","BROOM","SHOVEL","FOOD","DRINK","ORANGE","LEMON","SINNER","SAINT"
AlchemyDescription:
Print
Color 14
Print Tab(36); "ALCHEMY": Color 15
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 ";: Color 14: Print "STONE";: Color 15
Print " into ";: Color 14: Print "GOLD.": Color 15
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 a"
Print " 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 ";: Color 14: Print "add";: Color 15: Print " or ";: Color 14: Print "remove";: Color 15: Print " a letter, before re-arranging them, so the word may"
Print " change in length several times as you progress."
Print
Print " As an example, we can change STONE into GOLD with 4 changes:"
Color 14: Print Tab(23); "STONE - TONE - GONE - LONG - GOLD": Color 15
Print
Print " If the wordslists directory is present, each word entered is checked against"
Print " these. If not, they are assumed to be legitimate words."
Print " The wordlist files are the Complete Collins Scrabble Words (2019)."
Print: Color 14
Print Tab(29); "Press a key to continue"
While InKey$ = "": Wend
Play ok$
LoadPairs
Choice: ' invites replacing best scores in file with defaults
Color 14
Locate 23, 17
Print "Would you like to delete all previous results (y/n)";
Sleep
Color 15: y$ = UCase$(InKey$)
If y$ = "Y" Then
Refresh
Play ok$
LoadPairs
End If
SetPair: ' Select pair of words
LoadPairs
Color 14: Print Tab(22); "Which pair would you like, from A to T";
getpair:
pair$ = UCase$(InKey$)
If pair$ < "A" Or pair$ > "T" Then GoTo getpair
If pair$ = Chr$(27) Then Stop
pairnumber = Asc(pair$) - 64
Locate 23, 15: Print "Would you like to peek at the previous best solution (y/n)"
showchain:
k$ = InKey$
If k$ = "" Then GoTo showchain
If UCase$(k$) = "Y" Then ShowBest
StartGame:
Cls
remain = 21: tries = 0: fail = 0 ' start each game with 21 tries remaining
first$ = firstwords$(pairnumber): last$ = lastwords$(pairnumber)
train$(pairnumber) = first$
target = targets(pairnumber): name$ = names$(pairnumber) ' get selected pair details
prev$ = first$ ' pretend the first was a previous try
Color 14
Locate 1, 39 - Int(Len(first$) / 2): Print first$; Tab(52); "Record:"; target ' display the first word in yellow on row 2
Color 15
For a = 2 To maxtries + 1: Locate a, 35
Print String$(9, "."): Next ' show 9 dots for each try (rows 2 to 21)
Color 14
Locate 22, 39 - Int(Len(last$) / 2): Print last$; ' display the last word in yellow on row 23
tryvert = 2 ' row 3 will take the first try
InviteTry:
If tries = maxtries Then
Play fail$
WIPE "23": Color 3:
Locate 23, 21: Print "You've Used up all of your tries, sorry!"
WIPE "24"
Color 15
Sleep 3
GoTo StartGame ' ran out of tries, restart the same pair
Else
Locate tryvert, 35: Print String$(9, "."); Tab(46); Space$(30)
WIPE "23": Color 14 ' refresh remaining tries advice
Locate 23, 27
Print "You have"; 20 - tries; "tries remaining"
Locate tryvert, 3 ' display invite at tab 10 of current try-line
Print "Your word (q to quit)";
End If
DealWithTry:
Locate tryvert, 25
Input try$ ' show ? outside try-line and set try to first dot
Color 15
try$ = UCase$(try$)
If try$ = "Q" Then Stop
If try$ < "A" Or try$ > "Z" Then Play fail$: GoTo SetPair
tries = tries + 1
Locate tryvert, 35: Print Space$(12)
Locate tryvert, 39 - Int(Len(try$) / 2): Print try$
CheckWord ' Call Sub to Check the Player's Word
DealWithCheck:
Locate tryvert, 1: Print Space$(35)
If fail = 1 Then
Locate tryvert, 35: Print " "
Color 3
Locate tryvert, 39 - Len(try$) / 2
Print try$
Color 15
tryvert = tryvert + 1
GoTo InviteTry
Else
If try$ = last$ Then
Finished
GoTo SetPair
Else
Locate 23, 30
Print Space$(50)
tryvert = tryvert + 1
GoTo InviteTry
End If
End If
Sub Refresh
Restore
target = 21: name$ = "UNSOLVED!"
Open "alchpairs" For Output As #1
For a = 1 To 20
train$(a) = "UNSOLVED!"
Read first$, last$
Write #1, first$, last$, target, name$, train$(a)
Print first$; " "; last$; target; name$
Next
Close
Cls
End Sub
Sub WIPE (ln$) ' call with ln$ string of 2-digit line numbers only eg "012223" for lines 1, 22 and 23
For a = 1 To Len(ln$) - 1 Step 2
Locate Val(Mid$(ln$, a, 2)): Print Space$(80);
Next
End Sub
Sub LoadPairs
Restore
Cls
Color 14: Print Tab(37); "Word Pairs"
Print Tab(20); "Pair"; Tab(30); "From"; Tab(41); "To"; Tab(50); "Best"; Tab(62); "By"
Color 15
If _FileExists("alchpairs") Then
Open "alchpairs" For Input As #1
For a = 1 To 20
Input #1, firstwords$(a), lastwords$(a), targets(a), names$(a), train$(a) ' loads word-pairs from "alchpairs" file
Color 14: Print Tab(20); Chr$(a + 64);: Color 15: Print Tab(30); firstwords$(a); Tab(40); lastwords$(a); Tab(50); targets(a); Tab(60); names$(a)
Next
Close #1
Else Refresh
End If
End Sub
Sub ShowBest
Cls: Locate 12, 2
If train$(pairnumber) = "UNSOLVED!" Then Print Tab(35);
Print train$(pairnumber): Sleep 2: Cls
End Sub
Sub CheckWord
added = 0: added$ = "": removed = 0: removed$ = "": fail = 0 ' initialise added, removed and fail flag
Locate tryvert, 48: Print Space$(32)
Locate tryvert, 48
CountAdded:
temp$ = prev$ ' use temp$ as sacrificial to keep prev$ intact while checking for added
For a = 1 To Len(try$) ' for each letter in try$...
l$ = Mid$(try$, a, 1) ' take a letter l$ of temp$
po = InStr(temp$, l$) ' find its position po in temp$ (if any)
If po < 1 Then ' if not found...
added = added + 1
added$ = added$ + l$ ' count it and add to added$
Else
Mid$(temp$, po, 1) = " "
End If
Next
CountRemoved:
temp$ = try$ ' use temp$ as sacrificial to keep prev$ intact while checking for added
For a = 1 To Len(prev$) ' for each letter in try$...
l$ = Mid$(prev$, a, 1) ' take a letter l$ of temp$
po = InStr(temp$, l$) ' find its position po in temp$ (if any)
If po < 1 Then ' if not found...
removed = removed + 1
removed$ = removed$ + l$ ' add it to added$
Else
Mid$(temp$, po, 1) = " "
End If
Next
If added > 1 Then Color 3 Else Color 15
Print "Added "; added$;
If removed > 1 Then Color 3 Else Color 15
Print Tab(60); "Removed "; removed$ ' show letters that have been added or removed, colour cyan if too many
DictionaryCheck:
If Not _DirExists("wordlists") Then isaword = 1: GoTo checksfinished
WIPE "23"
filename$ = "wordlists/" + Left$(try$, 1) ' select dictionary file of first letter of try-word
Open filename$ For Input As #1
getaword:
isaword = 0
While Not EOF(1)
Input #1, dictword$ ' read each word from dictionary
If try$ = dictword$ Then isaword = 1: Exit While ' if word is found, don't look any further
Wend
Close
checksfinished:
Locate 23, 1
If added > 1 Or removed > 1 Or isaword = 0 Then ' if more than one letter added or removed, or word not found, set fail flag
Play fail$
Color 3 ' colour of try changed to cyan if word failed
Print Tab(35); "Word failed";
Color 15
fail = 1
Else
Play ok$
Print Tab(37); "Word ok"; ' otherwise, declare word as ok and make this the new prev$
prev$ = try$
train$(pairnumber) = train$(pairnumber) + "-" + try$
End If
Sleep 1
WIPE "23"
End Sub
Sub Finished
Play ok$: Play ok$
Locate tryvert, 35: Print Space$(12)
Locate tryvert, 39 - Len(try$) / 2: Print try$
WIPE "2223"
Locate 22, 21: Color 14: Print "You did it in"; tries; "changes. Target was"; targets(pairnumber)
Sleep 2
If tries >= targets(pairnumber) Then ' if target is not beaten,
Exit Sub ' go back for next game
Else
targets(pairnumber) = tries ' change the target for that pair to the new best score
Cls
Locate 10, 4
Input "Enter a name for the Best Scores list (or <ENTER> for anonymous)"; winname$ ' get the player's name
If Len(winname$) < 2 Then winname$ = "ANONYMOUS" ' if <ENTER> (or only one character) is given, name is Anonymous
names$(pairnumber) = UCase$(winname$) ' change the name for that pair to the new name
Open "alchpairs" For Output As #1
For a = 1 To 20
Write #1, firstwords$(a), lastwords$(a), targets(a), names$(a), train$(a) ' re-write the alchpairs file with the new details
Next
Close
End If
Cls
Locate 10, 40 - Len(train$(pairnumber)) / 2: Print train$(pairnumber)
Print: Print Tab(36); "Press a key"
Sleep
End Sub
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) 
![[Image: Cup-to-Plate.png]](https://i.ibb.co/xMqXTV7/Cup-to-Plate.png)