Keyboard input anomaly. This is present in all releases, I suspect.
So where the heck is it?
Go to the lower right and click the "Find [ " input line. Type foo. place cursor under the last "o" of foo. Now press the delete key. What?! The "o" will move to the right, instead of being deleted.
Hello,
I really enjoy working with qb64PE. However, I am missing some functions.
Would it be possible to add some date functions? They are completely missing and I need them often.
such as: day of the week, day of the year
It would also be nice if you could calculate with the day numbers
Font = _LoadFont(Font$, Size, "memory,monospace") 'load fonts at new size
FontBold = _LoadFont(FontBold$, Size, "memory,monospace")
FontItalic = _LoadFont(FontItalic$, Size, "memory,monospace")
w = _Width
h = _Height
fw = _UPrintWidth("W")
fh = _ULineSpacing ' MaxX = w \ fw 'calculate the max amount of text we can put on the screen ' MaxH = h \ fh
MaxX = _Width - 1
MaxY = _Height - 1
SubAddWord (word$, desc$, action$, insensitive) If word$ = ""ThenExit Sub'can't process a blank word If action$ = ""ThenExit Sub'can't be bothered to try and process a word that does nothing. For i = 0ToUBound(Words) If Words(i).word = ""Then'we're at blank words. Insert this new one. Exit For Else If Words(i).insensitive = 0Then If Words(i).word = word$ ThenExit Sub'this is a place to add new words, not screw around with old ones! Exit! Exit, Will Robinson! Else If_StriCmp(Words(i).word, word$) = 0ThenExit Sub'this is a place to add new words, not screw around with old ones! Exit! Exit, Will Robinson! End If End If Next ReDim_Preserve Words(10000 + UBound(Words)) As Word_Type 'we has a shitload of words! Make room for more!!
Words(i).word = word$
Words(i).desc = desc$
Words(i).action = action$
Words(i).insensitive = insensitive End Sub
l$ = Left$(temp$, bp - 1) 'don't get the break point itself; we'll deal with it afterwards
pw = _UPrintWidth(l$) If pw <= MaxLineWidth Then'the word fits on the current line ProcessWord l$
temp$ = Mid$(temp$, Len(l$) + 1)
TextX = TextX + pw 'move to end of word Else'the word is too long to fit on the current line If pw > MaxX Then'WTH? One word longer than our whole line? Break that bastard! It'll never fit on ANY line! For i = 1To bp If_UPrintWidth(Left$(temp$, i)) > MaxLineWidth ThenExit For Next _UPrintString (TextX, TextY), Left$(l$, i - 1) 'print what we can on this line
temp$ = Mid$(temp$, i) AddLine Else'the word can fit unbroken. We just move it down to the next line. AddLine ProcessWord l$
temp$ = Mid$(temp$, Len(l$) + 1)
TextX = pw 'move to end of word End If End If
This is a work-in-progess word wrap system which also processes "Action words".
And what the BLEEEP is an "Action word", you ask??
It's a word that causes an action!!
Umm... Think a hyperlink. Click it, and it opens up a webpage.
Though, in this case, I expect it to be able to do more things for me -- such as popup a text descriptor or a word, or perhaps an image, or give a creatures stats or weapon quality, or....
Yout get it, I hope -- it's a word which we can then process to perform an ACTION!!
In this work-in-progress demo, I only have ONE action supported at the moment: Create a text pop up to add description about a word.
Other actions will come as time allows.
And what the heck is ALL this for you ask?
The engine behind what I hope to be a very interactive and intuitive Text-Adventure Game. Want more information on an antique desk in the room? Instead of typing something like "Inspect desk" and getting a "You can not inspect that" type message, you can tell at a glance if the desk is underlined and highlighted as an interactive object. Left click it to inspect it. Right click it to pull up a popup to interact with it (try to move it, ect)...
Resizable, word-wrapping, with action words! Who could ever want anything more??
I was working on a way to extract individual sprites (or images) from a sprite sheet. Most sprite sheets found on the Internet are not neatly organized in same sized rectangular areas across the sheet.
At first I tried to design a line follower that would trace around sprites to find their area. That was like herding cats.
It then occurred to me that a flood fill like recursive routine may work. It does! The code below is a quick hack to show the concept in action. You'll need the image to see the code in action.
There's still some issues to work out but I thought someone might like to play with the code as is.
Code: (Select All)
' Parse a sprite sheet concept
'
' Issues to overcome:
' - Individual pixels are seen as separate sprites (the last 5 sprites in image)
' Somehow the code needs to intelligently decide that these pixels belong to a sprite
'
TYPE XY
x AS INTEGER
y AS INTEGER
END TYPE
DIM Min AS XY ' minimum x,y values seen
DIM Max AS XY ' maximum x,y values seen
DIM Background AS _UNSIGNED LONG ' background color to use as border
DIM Pixel AS _UNSIGNED LONG ' pixel color
DIM SourceSheet AS LONG ' source image containing sprites
DIM TargetSheet AS LONG ' target image to write found sprites to
DIM x AS INTEGER ' horizontal coordinate counter
DIM y AS INTEGER ' vertical coordinate counter
y = 0 ' reset vertical counter
DO
x = 0 ' reset horizontal counter
DO
' scan right until a pixel is found
Pixel = POINT(x, y) ' get pixel color
IF Pixel <> Background THEN ' is this pixel part of a sprite?
' A pixel has been found
Min.x = x ' set starting point of min/max x,y values seen
Max.x = x
Min.y = y
Max.y = y
GrabSprite x, y, SourceSheet, TargetSheet, Background ' recursively get sprite
' Now the sprite has been written to the target image and the min/max x,y coordinates are known
' Grab the written sprite as you wish and then remove it from the target sheet
' This nethod would work just as well if for instance the mouse pointer was used to click
' anywhere inside of a sprite to extract it.
' Quick code to show the concept in action
_DEST 0
_PUTIMAGE (0, 0), SourceSheet
_PUTIMAGE (0, 360), TargetSheet
LOCATE 1, 1
PRINT Max.x - Min.x, Max.y - Min.y ' current sprite dimensions
_LIMIT 5 ' slow down to see progress
END IF
x = x + 1
LOOP UNTIL x = _WIDTH(SourceSheet)
y = y + 1
LOOP UNTIL y = _HEIGHT(SourceSheet)
SUB GrabSprite (x AS INTEGER, y AS INTEGER, s AS LONG, t AS LONG, Border AS _UNSIGNED LONG)
' Recursively grabs an image within the border color specified (proof of concept)
' (Based on flood fill)
' x,y - pixel coordinate
' s - source image
' t - target image
' b - border (background) color
SHARED Min AS XY
SHARED Max AS XY
DIM Pixel AS _UNSIGNED LONG
IF x = -1 OR y = -1 OR x = _WIDTH(s) OR y = _HEIGHT(s) THEN EXIT SUB ' leave if x,y outside of source image
_SOURCE s ' get from source image
Pixel = POINT(x, y) ' get pixel color
IF Pixel = Border THEN EXIT SUB ' leave if pixel is border color
_DEST t ' draw on target image
PSET (x, y), Pixel ' copy pixel to target image
_DEST s ' draw on source image
PSET (x, y), Border ' remove pixel from source image
MinMax x, y, Min, Max ' get x and y extremes seen
GrabSprite x - 1, y, s, t, Border ' examine surrounding pixels
GrabSprite x + 1, y, s, t, Border
GrabSprite x, y - 1, s, t, Border
GrabSprite x, y + 1, s, t, Border
GrabSprite x - 1, y - 1, s, t, Border
GrabSprite x - 1, y + 1, s, t, Border
GrabSprite x + 1, y - 1, s, t, Border
GrabSprite x + 1, y + 1, s, t, Border
END SUB
SUB MinMax (x AS INTEGER, y AS INTEGER, min AS XY, max AS XY)
IF x < min.x THEN
min.x = x
ELSEIF x > max.x THEN
max.x = x
END IF
IF y < min.y THEN
min.y = y
ELSEIF y > max.y THEN
max.y = y
END IF
The setup I'm currently using cannot view any QB64PE programs in full screen. I highly suspect this occurred when I made a specialized change to my desktop display, so my flat screen would allow my desktop to be displayed correctly when the lid was opened and closed. Since this problem occurs with all my previous QB64PE versions, I know it isn't a Phoenix issue. So, I'm curious. Has anyone else experienced an inability to get a graphics program to stretch to all 4 corners of the monitor? To clarify, _FULLSCREEN in my set up creates a full black screen but only fills it with a windowed sized active screen in the lower left corner. So the upper and right side areas of the screen remain black.
This is no priority, and if I can't get full screen working, I won't miss it. Oh, I should mention I cannot see how it displays on my laptop alone, as the display screen was recently broken; however, I have used this laptop with a flat screen monitor before, with no changes to the Windows display, and I had not experienced the problem.
Got our billing notice today for the forum costs for this year:
I was estimating our costs at $300 a year... The actual total is a few pennies shy of $302.00. How's that for an eductated guess!!
Some folks don't like to be bothered with this type of information, but I prefer to keep all our costs, donations, and finances as transparent and available as possible, for those who might be curious about us -- or perhaps just curious what it might cost for them to set up an online site of their own.
There *ARE* cheaper plans available out there, but this one gives us unlimited storage and unlimited bandwidth (which, let's be honest, we mainly transfer text on this server and that's not using a ton of either -- not like some music or video streaming site!), so we never have to worry about how we might want to expand or develop things in the future. And, we're 100% AD FREE!! The worst you guys normally have to deal with for ads is the occasional once-a-year reminder that our bill is coming due and it's time to get in last minute donations, if anyone wants to.
As of this moment, our donations have covered about $250 of that $300 (honestly, I don't have the exact figure in my brain this early in the morning yet, and I'm too lazy to look it up right now before I have my coffee!!), with a couple of pledges of "the check is in the mail!" Provided the mail doesn't lose those checks, we should be covered for that yearly cost already.
If our donations this year exceeds our cost, as I've mentioned elsewhere, I'll either:
1) Swap to a longer plan which is more expensive up front, but cheaper on a per-month average price.
or
2) Just let the excess balance carry over to next year.
Posted by: PhilOfPerth - 03-02-2024, 07:13 AM - Forum: Games
- No Replies
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.
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
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
Don't send people messages and have your profile set to deny messages in return. It makes it more than a little hard to respong to you! Pbbbttttbtttt!!!
Your email issues should be sorted out now. If not... Turn on messaging and leave a message after the beep.
