Alchemy.7z (Size: 355.16 KB / Downloads: 71)
I've re-written the word-game Alchemy with several new innovations, which I think make it more enjoyable.
It has 3 sets of 20 word-pairs, roughly sorted in order of difficulty from easy to hard. All pairs are
proven to be solvable, with the current best results stored as three Previous best files. These automatically
update when the records are beaten, but can be removed and re-started at will.
It allows re-starting a word-pair, or re-picking the set of words. A random-access word file is included which
makes the word-checking function much faster.
My thanks to Steve and bplus for their help.
Code: (Select All)
Common Shared Ln$, SetNum$, Filename$, LineNum, CPL, WordPos, bad$, ok$, a$, Set$()
Common Shared Pairnum, Prev$, First$(), Last$(), Best$(), Name$(), Chain$(), Target$(), Target$, Name$
Common Shared ThisChain$, TryVert, Try$, Tries, MaxTries, Result
Randomize Timer
WWidth = 1275: WHeight = 820
Screen _NewImage(WWidth, WHeight, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 24, "monospace")
_Font f& ' install monospace font size 24, giving 32 usable text rows of 66 cols
dw = _DesktopWidth: dh = _DesktopHeight
CPL = WWidth / _PrintWidth("X") ' characters per line - used for centring and wiping
lhs = (dw - WWidth) / 2: top = 100 ' window left and top locations
_ScreenMove lhs, top
ok$ = "o3l32ceg": bad$ = "o2l16gec" ' centre display on target screen
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","GREEN","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"
Dim Set$(3, 20, 5) ' First, Last, Best, Name and Chain for 3 sets of 20 pairs
CheckFiles: ' check 3 Set files; if not found create with defaults
For a = 1 To 3
Filename$ = "Set" + LTrim$(Str$(a))
txt$ = "Checking " + Filename$
Centre txt$, 15: _Delay .5
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", "UNSOLVED"
Next
Print "created "; Filename$: Sleep 1
Close: Cls: Run
End If
Next
Description
Chooseset:
Centre "Choose from Set 1 to Set 3 (9 TO EXIT)", 15
SetNum$ = ""
While SetNum$ <> "9" And (SetNum$ < "1" Or SetNum$ > "3")
SetNum$ = InKey$
Wend
If SetNum$ = "9" Then System
Cls
ReDim First$(20), Last$(20), Best$(20), Name$(20), Chain$(20)
ShowPairs
MaxTries = 20: WordPos = 36
InviteChoosePair: ' choose a pair of words to attempt
Yellow: Centre "Choose a pair, from A to T", 29
Centre "Z to re-choose set number", 30 ' choose pair Z to change set number
Centre " * to reset this pair's history", 31
Centre "(ESC to quit)", 32 ' Esc quits the game
_KeyClear: k = 0
While k < 1
_Limit 30
k = _KeyHit
Wend
Cls
Select Case k
Case Is = 42, 56 ' press * to reset this pair history
Wipe "303132"
Centre "Do you really want to remove the history for this set (y/n)?", 30
_KeyClear
k$ = ""
While k$ = ""
k$ = InKey$: Wend
If UCase$(k$) <> "Y" Then
GoTo Chooseset
Else
If SetNum$ = "1" Then
Restore Set1Data ' start reading pairs at Set1Data
ElseIf SetNum$ = "2" Then
Restore Set2Data ' start reading pairs at Set1Data
ElseIf SetNum$ = "3" Then
Restore Set3Data ' start reading pairs at Set1Data
End If
Filename$ = "Set" + SetNum$
Open Filename$ For Output As #1 ' re-create the Set file with this data
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 file
Next
Close
Cls: msg$ = Filename$ + " reset"
Centre msg$, 15
Sleep 1
GoTo Chooseset
End If
Case Is = 27 ' Esc to quit
System
Case Is = 90, 122 ' Z or z to re-choose set
GoTo Chooseset
Case 65 To 84 ' selected A to T
Pairnum = k - 64 ' convert to number 1 to 20 uppercase
Case 97 To 116 ' a to t
Pairnum = k - 96 ' convert to number 1 to 20 lower-case
Case Else ' if it's none of these, try again
Play bad$
GoTo Chooseset
End Select
FirstLook:
Cls: ThisChain$ = "" ' empty the chain for this pair
Prev$ = First$(Pairnum) ' put start word at front of chain
TryVert = 6: remain = 21: Tries = 0
target = Val(Best$(Pairnum)): Name$ = Name$(Pairnum)
msg$ = "Target:" + Str$(target)
Centre msg$, 4 ' show target details for this pair
Yellow: Centre First$(Pairnum), 5 ' show the first word
For a = TryVert To MaxTries + 5
Print Using "##"; Tab(28); a - 5;
Centre String$(9, "."), a
Next ' show 9 dots for each try
Yellow: Centre Last$(Pairnum), 26 ' show the target word
_KeyClear
CheckNumTries:
If Tries = MaxTries Then ' check if all tries used yet
Play bad$
Wipe "30"
Red: Centre "You've Used up all of your tries, sorry!", 30
Wipe "24": White: Sleep 1
GoTo Chooseset ' if all tries used, advise and restart the same pair
End If
GetTry:
Centre String$(9, "."), TryVert
Yellow:
Wipe "30"
txt$ = "You have" + Str$(20 - Tries) + " tries remaining"
Centre txt$, 30
Yellow
Locate 5, 50: Print "Added"; Tab(60); "Removed"
Sleep 1
'For a = 0 To 2: Locate 5 + a, 5: Print Space$(21):Next
Locate 5, 2: Print "Enter your word"
Locate 6, 2: Print "Space to restart from top"
Locate 7, 2: Print "Esc to quit"
White
Locate TryVert, WordPos - 5: Print Space$(12) ' clear the Try space
Locate TryVert, WordPos - 2
Input "", Try$ ' place cursor outside try-line
Try$ = UCase$(Try$)
Select Case Try$
Case Is = Chr$(27) ' pressed Esc to quit
System
Case Is = Chr$(32) ' pressed space to restart from try 1
GoTo FirstLook
Case "A" To "Z", "a" To "z" '
GoTo Letters
Case Else
GoTo GetTry
End Select
Letters:
If Len(Try$) < 2 Or Len(Try$) > 9 Then ' check length is 2 to 9 letters
Play bad$
Red: Centre "Words from 2 to 9 letters only allowed", 29
Sleep 1: Wipe "29": White
Locate TryVert, WordPos
Print Space$(15) ' if length is wrong, erase,
GoTo GetTry ' and start this try again
End If
Tries = Tries + 1
Locate TryVert, WordPos: Print Space$(12)
Centre Space$(9), TryVert
Centre Try$, TryVert
CheckWord ' Call Sub to Check the Player's Word
TryVert = TryVert + 1
GoTo CheckNumTries
' ------------------------------------------------------------------- subs below -------------------------------------------------------------------
Sub ShowPairs
Filename$ = "Set" + SetNum$
Open Filename$ For Input As #1
For a = 1 To 20
Input #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a)
Next
Close
txt$ = Filename$ + " Word Pairs "
Yellow: Centre txt$, 5 ' show pair details, but don't show chains
Print: Print Tab(18); "Pair"; Tab(26); "From"; Tab(37); "To"; Tab(44); "Best"; Tab(52); "By"
White
For a = 1 To 20
Print Tab(19); Chr$(a + 64); Tab(26); First$(a); Tab(36); Last$(a); Tab(45); Best$(a); Tab(50); Name$(a)
Next
Close
Play ok$
End Sub
Sub CheckWord ' check this word - number of changes ok? valid word?
Added = 0: Added$ = "": Removed = 0: Removed$ = "": Result = 0
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 ' if in temp$, replace with a space (stops 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$ (removed)
temp$ = Try$ ' backup try$ before checking
For a = 1 To Len(Prev$)
l$ = Mid$(Prev$, a, 1) ' get a letter from prev$
po = InStr(temp$, l$) ' find its position in try$, if any
If po = 0 Then ' if not in temp$ it has been removed,
Removed = Removed + 1: Removed$ = Removed$ + l$ ' so add to Removed$ and increment the Removed count
Else ' if in temp$, replace with a space to (stops double-find)
temp$ = Left$(temp$, po - 1) + " " + Right$(temp$, Len(temp$) - po)
End If
Next
Locate TryVert, 50: Print Added$; Tab(60); Removed$
ResultOfCount: ' check number of added and removed letters
If Added > 1 Or Removed > 1 Then
Wipe "30"
Red: Centre "Too many changes!", 30
Play bad$
Sleep 1
Result = 1 ' flag too many changes with Result = 1
White
GoTo ChecksFinished ' bad result, no more checking needed
End If
DictionaryCheck: ' number of changes was ok, result is zero
Close
Open "RA9" For Random As #1 Len = 13 ' random access file with longest word 9 letters
fl = LOF(1) \ 13 + 1 ' get number of words in dictionary
bot = 0: top = fl
While Abs(top - bot) > 1
srch = Int((top + bot) / 2) ' set section of dictionary to searchrch ' set search point
Get #1, srch, a$ ' get a word from dictionary at srch point
a$ = UCase$(a$)
Select Case a$
Case Is < Try$ ' try$ is greater than dictionary word
bot = srch ' move search forward
Case Is > Try$ ' try$ is less than dictionary word
top = srch ' move search back
End Select
If Try$ = Last$(Pairnum) Then
msg$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Result = 2 ' solved
Yellow: Centre msg$, 31
Centre Try$, TryVert
' ThisChain$ = First$(Pairnum) + " - " + ThisChain$ ' + Try$ ' complete the chain
Exit While
ElseIf Try$ = a$ Then
Result = 3 ' valid word but not Last$
Centre Try$, TryVert
Exit While
End If
Wend
Close
InvalidWord: ' fall through to here if Try$ not Last$ and not valid
If Result < 2 Then
Wipe "30"
Red: Centre "Invalid word!", 30
Red: Centre Try$, TryVert
Sleep 1
ThisChain$ = ThisChain$ + " " + String$(Len(Try$), "*") + " - "
End If
Wipe "30" ' if we got here it's an invalid word, result still zero
White
ChecksFinished: '
Select Case Result
Case Is = 0, 1 ' word failed - too many changes or invalid word
Red: Centre Try$, TryVert
ThisChain$ = ThisChain$ + " " + String$(Len(Try$), "*") + " - "
Play bad$
Case Is = 2 ' word ok and last word is found
msg$ = "Solved in " + LTrim$(Str$(Tries)) + " tries!"
Yellow: Centre msg$, 31
Centre Try$, TryVert
ThisChain$ = First$(Pairnum) + " - " + ThisChain$ + Try$ ' complete the chain
If Len(ThisChain$) > CPL - 8 Then ThisChain$ = ThisChain$ + Chr$(13)
Case Is = 3 ' word ok but is not Last$
Centre Try$, TryVert
ThisChain$ = ThisChain$ + Try$ + " - "
Play ok$
Prev$ = Try$
End Select
If Result = 2 Then FinishedPair
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(Best$(Pairnum)) Then ' if this beats the Best for the current round,
Centre "New record! Enter your name (or <ENTER> for anonymous) ", 16
Locate 16, 60: Input winname$ ' get the player's name,
If Len(winname$) < 2 Then winname$ = "(ANON)" ' if no name is given, player is ANON
Name$(Pairnum) = UCase$(winname$) ' place Name of best player for this pair in array
Best$(Pairnum) = LTrim$(Str$(Tries)) ' place Best score for this pair in array
Chain$(Pairnum) = ThisChain$ ' this beats previous best so update chain$ for this pair,
Filename$ = "Set" + SetNum$ '
Open Filename$ For Output As #1
Cls
For a = 1 To 20 '
Write #1, First$(a), Last$(a), Best$(a), Name$(a), Chain$(a) ' and re-write the history file for this set
Next
Close
End If
Cls
Yellow
msg$ = "Best for this pair: " + Best$(Pairnum) + " by " + Name$(Pairnum)
Centre msg$, 15
White: Locate 17, 1: Print ThisChain$
Play ok$
Yellow: Centre "Press a key", 19
Sleep
Run
End Sub
Sub Description
AlchemyDescription:
Yellow: Centre "ALCHEMY", 2: White: Print
Print " Alchemy (al/ke/mi) is the process of changing items into something"
Print " different in a mystical way, such as changing ";: Green
Print "STONE";: White: Print " into ";: Green: Print "GOLD.": White
Print " This game calls upon your skills in this art, to change a word into"
Print " a totally different one, with the least number of changes.": Print
Print " In the usual word-swap game, you repeatedly change one letter of a"
Print " word for a different one, creating a new word, until the final word"
Print " is produced.": Print
Print " But in Alchemy you have another tool available to you for the task."
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"
Print " the length of the word may vary as you progress (to max 9 letters)."
Print " As an example, we can change STONE into GOLD with just 4 changes:"
Green: Centre "STONE - TONE - GONE - LONG - GOLD", 18: White: Print
Print " There are three sets of word-pairs provided, ranging from easy to";: Print
Print " difficult, and you are allowed up to 20 changes for each pair. A"
Print " record is kept of the best score for each pair, and if you beat"
Print " one of these, your record will replace it (you can restart these"
Print " records from new at any time).": Print
Print " By the way, an ";: Green: Print "Easter Egg";: White: Print " with ";
Print "the best recorded solutions for all"
Print " of the word-pairs is hidden somewhere (hint: you may have to visit"
Print " Tibet to find it)!"
Yellow: Centre "Press a key to continue", 29
Sleep: Play ok$: Cls
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 wipe-line,
wl = Val(Mid$(ln$, a, 2)) ' and wipe that line
Locate wl, 1: Print Space$(CPL);
Next
End Sub
Sub Centre (txt$, linenum) ' centres text on selected line
ctr = Int(CPL / 2 - Len(txt$) / 2) + 1 ' centre is half of chars per line minus half string-length
Locate linenum, ctr
Print txt$
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Green
Color _RGB(0, 255, 0)
End SubSTEVE FREINDLY EDIT -- Grab the download from here as well, if you need it:
Alchemy.7z (Size: 355.16 KB / Downloads: 71)
(Most folks are used to finding these attachments at the bottom of posts, so I just edited it down here as well as leaving it up top as originally posted.
)
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/
