Alchemy is fixed! - Printable Version

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