As there's been several people asking about how to display extended characters (such as greek characters) onto the screen, I thought _MAPUNICODE would be a nice word for today.
First: Download the attached unicode font file and extract it into your qb64pe root directory (the same one with the qb64pe executable).
Then copy and paste the code below into qb64pe, and run it:
Code: (Select All)
Screen _NewImage(1280, 720, 32)
f = _LoadFont("DejaVuSansMono.ttf", 24, "monospace")
_Font f
fw = _FontWidth: fh = _FontHeight 'font width, font height
cpl = _Width \ fw: cpp = _Height \ fh 'characters per line, characters per page
For y = 0 To cpp - 1
For x = 0 To cpl - 1
i = i + 1
_PrintString (x * fw, y * fh), Chr$(i)
If i = 255 Then GoTo skip 'show the first 255 that people are used to seeing usually.
Next 'then exit... This is just lazy formatting
Next
skip:
Sleep
'Just to show all the tons of different unicode symbols inside the unicode file...
i = 0
For y = 4 To cpp - 1
For x = 0 To cpl - 1
i = i + 1
_MapUnicode i To 0
_PrintString (x * fw, y * fh), Chr$(0)
If i = 255 Then Sleep 'show the first 255 that people are used to seeing usually.
Next 'then fill the page with extra junk! (I dunno what any of these are supposed to be. :P )
Next
Sleep
'Greek codes are 913 to 969
'note that there is no greek symbol at 930, so that unicode value has been recycled to be something else.
'pay no attention to it, if you don't need it. (And I don't think most people would.)
Cls
i = 912
Print "The Greek character set:"
For y = 1 To cpp - 1
For x = 0 To cpl - 1
i = i + 1
_MapUnicode i To 0
_PrintString (x * fw, y * fh), Chr$(0)
If i = 969 Then GoTo done
Next
Next
done:
'Latin is 256 to 328
i = 255
Locate 5, 1: Print "The Latin character set:"
For y = 5 To cpp - 1
For x = 0 To cpl - 1
i = i + 1
_MapUnicode i To 0
_PrintString (x * fw, y * fh), Chr$(0)
If i = 328 Then GoTo done2
Next
Next
done2:
Sleep
System
Running the above, we start out with a burst of characters across the screen that everyone should be familiar with -- the 255 ASCII characters that we see and use all the time in QB64!
Hit any key, and then you can see what the unicode characters from 1 to 255 look like. A large portion of the first half maps directly over from our current ASCII set to the UNICODE set of characters (everything from 32 to 128), but, as you can see, there's no symbols defined in our font for unicode characters 1 to 31. Those are/were control codes back in the day, and the vast majority of them were non-printing, so many unicode fonts don't have those characters in them. Our ASCII code actually maps unicode symbols from other values, and puts it in those spots, to make the character set that we're used to seeing.
Now from 128 to 255, there's not a single character which matches up between the unicode values and our ASCII values. We tend to, by default, map the character codes from codepage 437 into those spots, so that our codes will match the same ones QB45 and all other basics used to use by default. Now, one problem with this is that we aren't offering a lot of the specialized characters (such as those with various accents and such), as we're offering the old character sets that were used to build boxes and such in old terminal screens.
So, how would one fix that, if they wanted to display other symbols besides the ones we currently offer??
Hit any key in the demo, and you can see that there's a whole bunch of other characters inside the font we loaded! Even though QB64 only makes use of 256 of those characters, that doesn't mean our font doesn't have a whole lot more than 256 that we can choose from! (After all, if we couldn't use other characters, I'd never be able to create the demo that you're now viewing, now would I??)
To pick and choose our display set, we simply make use of the _MAPUNICODE command. To easily get the most out of this command, I recommend the following steps:
1) Go to ✔️ ❤️ ★ Unicode Character Table (unicode-table.com) -- There's a ton of unicode symbols available out there. Find which code corresponds to the character you want.
2) Find a current ASCII character that you're not using. For my demo, I chose CHR$(0) for all my needs -- you can choose any of the 0 to 255 characters to replace that you want.
3) _MAPUNICDE unicode_number TO ascii_number
It's that simple!!
Now, whenever you need to display that character upon the screen, you can call upon it as needed.
PRINT "Hello World " + CHR$(150) '150 for whatever symbol/character you decided to map to 150.
Note that not every unicode font has every unicode character in it. When you run my demo, you'll see several square boxes -- that's default for "Nope! No symbol here!" If the font you have doesn't support the language/symbols you need, then you'll just have to swap to a different font. After all, you can't print characters that don't exist in your font set!
Posted by: PhilOfPerth - 11-22-2022, 03:03 AM - Forum: Programs
- No Replies
This is an updated version of my Wordfind programme. It now finds and displays all words that can be derived from a given word, using each letter only once, up to 30 characters in length.
Color 14: Locate 6, 35: Print "Word-Find": Color 15
Print Tab(30); "By Phil Taylor (2022)": Print
Print Tab(5); "This programme will find all English words up to 13 letters in length"
Print Tab(5); "that appear in the Collins (2019) dictionary, that can be formed from "
Print Tab(5); "the letters of a word or group of letters, with each letter only being"
Print Tab(5); "used once."
Print: Print Tab(10); "(You can specify minimum and maximum word-lengths to find)."
Print
Color 14: Print Tab(15);: Input "Minimum size of words (ENTER for default of 2)"; min$
If Val(min$) < 2 Then min = 2 Else min = Val(min$)
Color 15: Print Tab(30); "Minimum set at "; min: Color 14
Print
Print Tab(15);: Input "Maximum size of words (ENTER for default of 30)"; max$
If Val(max$) < 2 Then max = 30 Else max = Val(max$)
Color 15: Print Tab(30); "Maximum set at"; max
Print: Color 14: Print Tab(30); "Press a key to start": Color 15
While InKey$ <> "": Wend
While InKey$ = "": Wend
Start:
Cls
While InKey$ <> "": Wend
Locate 10, 20: Color 14: Input "What is the Base-Word (or group)"; base$: Color 15
If base$ < "A" Then base$ = "ANYTHING" ' just a word for demo purposes
base$ = UCase$(base$)
origbase$ = base$
Color 14: Print Tab(9); "Base word:"; origbase$; " Minimum length:"; min; " Maximum length:"; max: Color 15
sort:
swapped = 0
For a = 1 To Len(base$) - 1
If Mid$(base$, a, 1) > Mid$(base$, a + 1, 1) Then
t1$ = Mid$(base$, a, 1): t2$ = Mid$(base$, a + 1, 1)
Mid$(base$, a, 1) = t2$: Mid$(base$, a + 1) = t1$
swapped = 1
End If
Next
If swapped = 1 Then GoTo sort
Print a$
l = Len(base$)
found = 0: totfound = 0
sorted$ = Left$(base$, 1)
Cls
FindUnique
For bletrnum = 1 To l ' for each letter in base$
fileletr$ = Mid$(base$, bletrnum, 1)
po = InStr(unique$, fileletr$)
If po = 0 Then GoTo skip
Mid$(unique$, po, 1) = " "
dictfile$ = "wordlists/" + fileletr$
Close
Open dictfile$ For Input As #1
GetAWord:
While Not EOF(1)
Input #1, dictwrd$
l = Len(dictwrd$): If l < min Or l > max Then GoTo GetAWord
WORDCHECK
Wend
skip:
Next
Print: Color 14: Print Tab(35); "Finished!"
Print Tab(29); "Total words found:"; totfound
Sleep
GoTo Start
Sub WORDCHECK
fail = 0
dummy$ = base$
For a = 1 To l
dictletr$ = Mid$(dictwrd$, a, 1)
po = InStr(dummy$, dictletr$)
If po = 0 Then
fail = 1 ' letter is not in dummy$ so abandon word
Else
Mid$(dummy$, po, 1) = " "
End If
Next
If fail = 1 Then Exit Sub
found = found + 1: totfound = totfound + 1
Print dictwrd$; Space$(1);
If Pos(0) > 70 Then Print
If found = 220 Then
While InKey$ <> "": Wend
Color 14
Print: Print Tab(27); "Press a key for next group"
While InKey$ = "": Wend
found = 0
Cls
Color 14: Print Tab(9); "Base word:"; origbase$; " Minimum length:"; min; " Maximum length:"; max: Color 15
Color 15
End If
End Sub
Sub FindUnique
unique$ = ""
For a = 1 To l
l$ = Mid$(base$, a, 1)
po = InStr(unique$, l$)
If po = 0 Then unique$ = unique$ + l$
Next
End Sub
A program can be at one of two promotion levels: development or production.
When at the development level, there are two versions of the program available: development and production.
When at the production level, there is only the one version of the program: production. Until edited, at which point it is back at the development level.
That aside:
We may want a program to look/behave differently depending on what version we are running/exporting. This is where the "dev" and "prod" preprocessor directives come in.
Sample code:
Code: (Select All)
<<dev """
greet$ = "howdy buds, this is the development version of the program"
""">>
<<prod """
greet$ = "good day ladies and gentlement, this is the production version of the program"
""">>
print greet$
In the sample code above, greet$ will have one value when we are running the development version, and a different value when running the production version.
Today's Keyword of the Day is the first which has poor Steve shaking his head and sighing deeply over our documentation and wiki entries on it. Guys, do me a favor and toss the wiki examples out of your brains, as they're NOT what you want to do with _MOUSEINPUT at all.
Let me illustrate with the first example from the wiki:
Code: (Select All)
DO
DO WHILE _MOUSEINPUT ' Check the mouse status
PRINT _MOUSEX, _MOUSEY, _MOUSEBUTTON(1), _MOUSEWHEEL
LOOP
LOOP UNTIL INKEY$ <> ""
Seems to work as advertised, so what's the problem here?
Nothing should go inside your _MOUSEINPUT loop, except for a _MOUSEWHEEL counter!
Let me show you why:
Code: (Select All)
Do
Locate 1
i = 1
Do While _MouseInput ' Check the mouse status
Locate i, 1: Print _MouseX, _MouseY, _MouseButton(1), _MouseWheel
i = i + 1
Loop
If i <> 1 Then For z = i To 20: Locate z, 1: Print Space$(60): Next
Locate 21, 1: Print _MouseX, _MouseY, _MouseButton(1)
_Limit 120
Loop Until InKey$ <> ""
Take the first code and imagine trying to actually do something with it. Printing it inside that example loop isn't actually doing anything constructive for us -- it's just displaying all the mouse's minute movements as it crosses the screen. If we're going to check the mouse against a button, or some such, that we've draw upon our screen, we'll need to settle on o single value for that mouse position which we compare against -- and that's going to be AFTER WE EXIT THE LOOP.
Code: (Select All)
Do While _MOUSEINPUT
Loop
^The above says we're not going to actually do anything with our _MOUSEX and _MOUSEY values... We'll only respond to them outside the loop.
And, as you can see from my second set of code, the end result is *always* going to print the same values as the last pass inside the loop did...
So why would we waste time processing a couple of dozen events, assigning them to overwrite the same values over and over and whatnot, when we're just going to toss those values out the door at the end of the loop??
IF both sets of the following code produce the same results, which is more efficient for us?
Code: (Select All)
While _MouseInput
x = _MOUSEX: y = _MOUSEY
Wend
Code: (Select All)
While _MouseInput; Wend
x = _MouseX: y = _MouseY
Both are going to generate the exact same values for x and y, so which is more efficient for us? The first code is going to assign several dozen temporary values to x and y, before exiting and giving us a final value for x and y. The second code skips all that intermittent assignment and just gives us the final result after the mouseinput loop.
Our second example in the wiki is just as poorly written, and is just as bad of an example.
Code: (Select All)
SCREEN 12
DO ' main program loop
' your program code
DO WHILE _MOUSEINPUT'mouse status changes only
x = _MOUSEX
y = _MOUSEY
IF x > 0 AND x < 640 AND y > 0 AND y < 480 THEN
IF _MOUSEBUTTON(2) THEN
PSET (x, y), 15
LOCATE 1, 1: PRINT x, y
END IF
END IF
LOOP
' your program code
LOOP UNTIL INKEY$ = CHR$(27)
Once again, the example is processing all sorts of crap inside that _MOUSEINPUT loop that it doesn't need to. Compile it. Run it. Watch how it behaves. And then compare to the following:
Code: (Select All)
Screen 12
Do ' main program loop
' your program code
Do While _MouseInput: Loop 'mouse status changes only
' your program code
x = _MouseX
y = _MouseY
If x > 0 And x < 640 And y > 0 And y < 480 Then
If _MouseButton(2) Then
PSet (x, y), 15
Locate 1, 1: Print x, y
End If
End If
Loop Until InKey$ = Chr$(27)
The only thing that needs to go inside a _MOUSEINPUT loop is possibly a counter to deal with _MOUSEWHEEL. Everything else should go outside it, or else you're going to end up lagging up your program to the point of uselessness.
MouseInput code should generally look like one of the two varieties below:
Code: (Select All)
While _MouseInput: Wend
Code: (Select All)
While _MouseInput
scrollwheel = scrollwheel + _MOUSEWHEEL
Wend
Attempting to process other code inside that mouseinput loop is just asking for trouble. Our wiki examples work for what they're showing, but what they're showing is about the worst possible structure I could imagine for use with _MOUSEINPUT. Honestly, they must've just written into the wiki when _MOUSEINPUT was first added into the wiki and nobody knew much about it.. As it stands now, those examples need an overhaul to show how to actually use them properly.
Just published a small update to the last release of QBJS. I've added a screen pixel cache to improve the performance of programs that heavily utilize PSET for rendering.
For example, @vince's American flag now majestically waves at a more acceptable rate. Not quite as fast as native QB64 on my box, but a lot closer than before.
Also, there have been a number of posts recently of "Bubble Universes" which also run a lot faster:
Note: If you are not seeing an improvement when you try these examples, you might need to do a SHIFT+Refresh to clear the cached version in your browser.
I don't know much about this topic of accessing PC/Mac/Linux devices.
Is it possible to capture a still image from a USB camera from within a QB64 program? Or would this be incredibly complicated? Obviously the easiest thing to do is just manually capture the image (using the camera software) then _loadimage into QB64.
I'm wondering if QB64 could be used to capture a new image at a certain time interval and discard the previous image.
I would like to ask a question to the community here.
How easy is it for QB64 to support the Greek language?
That is, what is written in quotation marks.
For example,
PRINT "Den ypostirizo ellinikoys xaraktires>"
PRINT "I do not support Greek characters."
PRINT "Δεν υποστηρίζω ελληνικούς χαρακτηρισμούς."
SLEEP
Copy this little example and you'll see exactly what I mean.
I would like one day to be able to make my own programs and insert Greek characters where needed.
Mini-Robo-Mixer generates a sprite sheet of robots.
Code: (Select All)
'Mini-Robo-Mixer v0.1
'By James D. Jarvis November 2022
'This program uses BASIMAGE coded by Dav for QB64GL 1.4, MAY/2020
'
'generate a sprite sheet of monsters
'each is 64 by 64 pixels but code here can be modified to change that
'
'press c or s to save a sprite sheet to the clipboard so you can paste it into a paint program
'and save is whatever format you desire
'pres <esc> to quit
'
'License: Share sprite sheets as long as they include generated credit bar in image
'any programs using original code or graphics from source or generated by program
' please include the following (or equivalent) line somwhere in comments and documentation:
'Includes Art and/or Code from Mini-Robo-Mixer v0.1 created by James D. Jarvis
'
Randomize Timer
Dim Shared ms&
ms& = _NewImage(512, 360, 32)
Screen ms&
_Title "Mini-Robo-Mixer V0.1"
Dim Shared part&
Dim Shared kk1 As _Unsigned Long
Dim Shared kk2 As _Unsigned Long
Dim Shared kk3 As _Unsigned Long
Dim Shared kk4 As _Unsigned Long
Dim Shared kk5 As _Unsigned Long
Dim Shared kk6 As _Unsigned Long
Dim Shared clr~&
part& = BASIMAGE1&
Type robobody_type
head As Integer
larm As Integer
rarm As Integer
torso As Integer
leg As Integer
k1 As _Unsigned Long
k2 As _Unsigned Long
k3 As _Unsigned Long
k4 As _Unsigned Long
k5 As _Unsigned Long
k6 As _Unsigned Long
xsiz As Integer
ysiz As Integer
End Type
robot_limit = 40
Dim klrset(12, 3) As Integer
Dim Shared rlook(robot_limit) As robobody_type
_Source part&
'read the colors from the color reference bar whichever color is in the top left corner will be transparent
clr~& = Point(0, 0) 'find background color of image
kk1 = Point(0, 1): kk2 = Point(0, 2): kk3 = Point(0, 3): kk4 = Point(0, 4): kk5 = Point(0, 5): kk6 = Point(0, 6)
_Dest part&
Line (0, 0)-(0, 8), clr~& 'erase the color reference bar from the bit map
_ClearColor clr~&, ms& 'set background color as transparent
_ClearColor clr~&, part&
_Source ms&
_Dest ms&
Do
Cls
'build a color set for the sprite sheet
For k = 1 To 12
klrset(k, 1) = Int(Rnd * 100 + 150)
If Rnd * 7 < 3 Then klrset(k, 2) = klrset(k, 1) Else klrset(k, 2) = Int(Rnd * 100 + 150)
If Rnd * 7 < 3 Then klrset(k, 3) = klrset(k, 1) Else klrset(k, 3) = Int(Rnd * 100 + 150)
Next k
mmx = 0: mmy = 0
For m = 1 To robot_limit
'create a new set of monster sprites
'included image source has 16 options for head,arms,torso, and legs
rlook(m).head = Int(1 + Rnd * 20)
rlook(m).larm = Int(1 + Rnd * 20)
If Rnd * 10 < 3 Then rlook(m).rarm = rlook(m).larm Else rlook(m).rarm = Int(1 + Rnd * 20)
rlook(m).torso = Int(1 + Rnd * 20)
rlook(m).leg = Int(1 + Rnd * 20)
'determing colors for this specific monster sprite
kp = 1 + Int(Rnd * 12)
kr = klrset(kp, 1): kg = klrset(kp, 2): kb = klrset(kp, 3)
kr2 = Int(kr / 2): kg2 = Int(kg / 2): kb2 = Int(kb / 2)
kp = 1 + Int(Rnd * 6)
kr3 = klrset(kp, 1) - 5: kg3 = klrset(kp, 2) - 10: kb3 = klrset(kp, 3) - 15
kr4 = Int(kr3 / 2): kg4 = Int(kg3 / 2): kb4 = Int(kb3 / 2)
kp = 1 + Int(Rnd * 6)
kr5 = klrset(kp, 1) - 20: kg5 = klrset(kp, 2) - 15: kb5 = klrset(kp, 3) - 7
kr6 = Int(kr5 / 2): kg6 = Int(kg5 / 2): kb6 = Int(kb5 / 2)
draw_robot mmx, mmy, m, 6
mmx = mmx + 64
If mmx >= _Width Then
mmx = 0
mmy = mmy + 64
End If
Next m
md$ = "Robot Sprite Sheet generated " + Date$ + " at " + Time$
md2$ = "Mini-Robot-Mixer V0.1 by James D. Jarvis"
_PrintString (0, 321), md$
_PrintString (0, 337), md2$
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
If kk$ = "C" Or kk$ = "c" Or kk$ = "S" Or kk$ = "s" Then
_ClipboardImage = ms&
_Delay 0.3
Locate 1, 1: Print "Sprite Sheet Saved to Clipboard"
Sleep 3
End If
Loop Until kk$ = Chr$(27)
_FreeImage part&
System
Sub draw_robot (Mx, my, mid, scale)
'generate a monster image from source sprite sheet part& and render to the programs main screen ms&
tempi& = _NewImage(64, 64, 32)
'tempi& creates a temporary one sprite image for rendering
_ClearColor clr~&, tempi&
_Dest tempi&
Cls
_Source tempi&
'repaint source image with generate color values for new monster sprite
For y = 0 To 63
For x = 0 To 63
Select Case Point(x, y)
Case kk1
PSet (x, y), rlook(mid).k1
Case kk2
PSet (x, y), rlook(mid).k2
Case kk3
PSet (x, y), rlook(mid).k3
Case kk4
PSet (x, y), rlook(mid).k4
Case kk5
PSet (x, y), rlook(mid).k5
Case kk6
PSet (x, y), rlook(mid).k6
End Select
Next x
Next y
'generated image in tempi& is rendered to ms& as a 64 by 64 sprite
_PutImage (Mx, my)-(Mx + 63, my + 63), tempi&, ms&
_Source ms&
_Dest ms&
_FreeImage tempi&
End Sub
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
![[Image: 118.png]](https://i.ibb.co/6Fx3YBZ/118.png)
