Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
Nesting Select Cases |
Posted by: PhilOfPerth - 05-28-2022, 11:55 PM - Forum: Help Me!
- Replies (2)
|
|
Can Select Case segments be safely nested, by placing another Select Case segment inside one or more of the primary Cases? Or will they "contaminate", messing up the stack of operations for the program?
I know we can nest For...Next and If...Then, but it's not made clear in the Help file whether this is ok for Select Case.
I'm still exploring, so this would be helpful to know.
|
|
|
QB64 odd behavior when Windows Terminal is set to default terminal app |
Posted by: hanness - 05-27-2022, 09:25 PM - Forum: General Discussion
- No Replies
|
|
In Windows 11, I go into Settings and then to the developer settings. Under "Terminal" I select Windows Terminal as the default terminal app to host command-line apps (the other choice would be the Windows Console Host).
After doing this, whenever I open the QB64 IDE, it also opens a Windows Terminal window. If I close that Terminal window, it also shuts down QB64. Likewise, if I close QB64, the Windows Terminal window also closes.
The next time I reopen QB64 it asks if I want to recover my program from an auto-saved backup.
Is this expected behavior?
My preference is to use Windows Terminal as the default terminal app, but this side-effect makes it awkward.
|
|
|
Embedding files in programs |
Posted by: RhoSigma - 05-27-2022, 11:32 AM - Forum: RhoSigma
- No Replies
|
|
Embedding any files into your programs by converting it into DATA lines or an C-Array
The following two small programs are meant to convert any file (eg. Images, Sounds, Databases etc.) into an easy embedable format. Embedding is then as simple as putting a $INCLUDE line at the end of your program. But note, this feature is not meant to save you from the task of loading a file and instead directly using the embedded data. It's designed only for the convenience of delivering just one file (your program's EXE), and hence also making sure all required files are always available on any user's computer, but the embedded data must be written out there again to be usable. The converted files will therefore have a "Ready to use" writeback function, which will rebuild the embedded file on disk, from where you then eg. _LOADIMAGE regularly.
The first converter tool is named MakeDATA, as you may imagine by its name, it will convert the given file into a block of DATA lines. This is easy to use and absolutly BASIC only. It's best to embed small files like icons or sprites. However, for large files like fullsize digital photos or MP3 music it has a big drawback at the compiling speed of your program and the final EXE size on one side and also to the writeback speed on the other side.
So for bigger files the second tool MakeCARR should be your choice, which its advantages are detailed below the MakeDATA codebox.
Note for Windows users:
The codeboxes below contain simple SCREEN 0 (text) based versions of the converter tools. You may have to go in to change your default paths, but they should work reliable on all OS's supported by QB64.
If you're on Windows, then you may rather wish to use the more convenient GuiTools based versions, just move on to
The GuiTools Framework here: https://staging.qb64phoenix.com/forumdisplay.php?fid=32
Both converter tools are available as part of the QB64GuiTools.7z source archive.
And now for the simple (SCREEN 0) people:
Both of the following tools require the 'lzwpacker.bm' file available from my Libraries Collection here:
https://staging.qb64phoenix.com/forumdisplay.php?fid=23
If you're using at least QB64 v1.4 or any Phoenix Edition version and don't wanna use the extra Lzw packer libarary, but the QB64 built-in zlib compression instead, then simply substitute the LzwPack$ call (line 84) with the respective _DEFLATE$ call and the LzwUnpack$ call (line 187) with an _INFLATE$ call. Also delete the $INCLUDE line at the end.
MakeDATA.bas
Code: (Select All)
'+---------------+---------------------------------------------------+
'| ###### ###### | .--. . .-. |
'| ## ## ## # | | )| ( ) o |
'| ## ## ## | |--' |--. .-. -. . .-...--.--. .-. |
'| ###### ## | | \ | |( )( ) | ( || | |( ) |
'| ## ## | ' ' - -' -'-' -- |' ' - -'- |
'| ## ## # | ._.' |
'| ## ###### | Sources & Documents placed in the Public Domain. |
'+---------------+---------------------------------------------------+
'| |
'| === MakeDATA.bas === |
'| |
'| == Create a DATA block out of the given file, so you can embed it |
'| == in your program and write it back when needed. |
'| |
'| == The DATAs are written into a .bm file together with a ready to |
'| == use write back FUNCTION. You just $INCLUDE this .bm file into |
'| == your program and call the write back FUNCTION somewhere. |
'| |
'| == This program needs the 'lzwpacker.bm' file available from the |
'| == Libraries Collection here: |
'| == https://staging.qb64phoenix.com/forumdisplay.php?fid=23 |
'| == as it will try to pack the given file to keep the DATA block |
'| == as small as possible. If compression is successful, then your |
'| == program also must $INCLUDE 'lzwpacker.bm' to be able to unpack |
'| == the file data again for write back. MakeDATA.bas is printing |
'| == a reminder message in such a case. |
'| |
'+-------------------------------------------------------------------+
'| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
'| Find me in the QB64 Forum or mail to support@rhosigma-cw.net for |
'| any questions or suggestions. Thanx for your interest in my work. |
'+-------------------------------------------------------------------+
'--- if you wish, set any default paths, end with a backslash ---
srcPath$ = "" 'source path
tarPath$ = "" 'target path
'-----
IF srcPath$ <> "" THEN
COLOR 15: PRINT "Default source path: ": COLOR 7: PRINT srcPath$: PRINT
END IF
IF tarPath$ <> "" THEN
COLOR 15: PRINT "Default target path: ": COLOR 7: PRINT tarPath$: PRINT
END IF
'--- collect inputs (relative paths allowed, based on default paths) ---
source:
LINE INPUT "Source Filename: "; src$ 'any file you want to put into DATAs
IF src$ = "" GOTO source
target:
LINE INPUT "Target Basename: "; tar$ 'write stuff into this file (.bm is added)
IF tar$ = "" GOTO target
'-----
ON ERROR GOTO abort
OPEN "I", #1, srcPath$ + src$: CLOSE #1 'file exist check
OPEN "O", #2, tarPath$ + tar$ + ".bm": CLOSE #2 'path exist check
ON ERROR GOTO 0
'--- separate source filename part ---
FOR po% = LEN(src$) TO 1 STEP -1
IF MID$(src$, po%, 1) = "\" OR MID$(src$, po%, 1) = "/" THEN
srcName$ = MID$(src$, po% + 1)
EXIT FOR
ELSEIF po% = 1 THEN
srcName$ = src$
END IF
NEXT po%
'--- separate target filename part ---
FOR po% = LEN(tar$) TO 1 STEP -1
IF MID$(tar$, po%, 1) = "\" OR MID$(tar$, po%, 1) = "/" THEN
tarName$ = MID$(tar$, po% + 1)
EXIT FOR
ELSEIF po% = 1 THEN
tarName$ = tar$
END IF
NEXT po%
MID$(tarName$, 1, 1) = UCASE$(MID$(tarName$, 1, 1)) 'capitalize 1st letter
'--- init ---
OPEN "B", #1, srcPath$ + src$
filedata$ = SPACE$(LOF(1))
GET #1, , filedata$
CLOSE #1
rawdata$ = LzwPack$(filedata$, 20)
IF rawdata$ <> "" THEN
OPEN "O", #1, tarPath$ + tar$ + ".lzw"
CLOSE #1
OPEN "B", #1, tarPath$ + tar$ + ".lzw"
PUT #1, , rawdata$
CLOSE #1
packed% = -1
OPEN "B", #1, tarPath$ + tar$ + ".lzw"
ELSE
packed% = 0
OPEN "B", #1, srcPath$ + src$
END IF
fl& = LOF(1)
cntL& = INT(fl& / 32)
cntB& = (fl& - (cntL& * 32))
'--- .bm include file ---
OPEN "O", #2, tarPath$ + tar$ + ".bm"
PRINT #2, "'============================================================"
PRINT #2, "'=== This file was created with MakeDATA.bas by RhoSigma, ==="
PRINT #2, "'=== you must $INCLUDE this at the end of your program. ==="
IF packed% THEN
PRINT #2, "'=== ---------------------------------------------------- ==="
PRINT #2, "'=== If your program is NOT a GuiTools based application, ==="
PRINT #2, "'=== then it must also $INCLUDE: 'lzwpacker.bm' available ==="
PRINT #2, "'=== from the Libraries Collection here: ==="
PRINT #2, "'=== https://staging.qb64phoenix.com/forumdisplay.php?fid=23 ==="
END IF
PRINT #2, "'============================================================"
PRINT #2, ""
'--- writeback function ---
PRINT #2, "'"; STRING$(LEN(tarName$) + 18, "-")
PRINT #2, "'--- Write"; tarName$; "Data$ ---"
PRINT #2, "'"; STRING$(LEN(tarName$) + 18, "-")
PRINT #2, "' This function will write the DATAs you've created with MakeDATA.bas"
PRINT #2, "' back to disk and so it rebuilds the original file."
PRINT #2, "'"
PRINT #2, "' After the writeback call, only use the returned realFile$ to access the"
PRINT #2, "' written file. It's your given path, but with an maybe altered filename"
PRINT #2, "' (number added) in order to avoid the overwriting of an already existing"
PRINT #2, "' file with the same name in the given location."
PRINT #2, "'----------"
PRINT #2, "' SYNTAX:"
PRINT #2, "' realFile$ = Write"; tarName$; "Data$ (wantFile$)"
PRINT #2, "'----------"
PRINT #2, "' INPUTS:"
PRINT #2, "' --- wantFile$ ---"
PRINT #2, "' The filename you would like to write the DATAs to, can contain"
PRINT #2, "' a full or relative path."
PRINT #2, "'----------"
PRINT #2, "' RESULT:"
PRINT #2, "' --- realFile$ ---"
PRINT #2, "' - On success this is the path and filename finally used after all"
PRINT #2, "' applied checks, use only this returned filename to access the"
PRINT #2, "' written file."
PRINT #2, "' - On failure this function will panic with the appropriate runtime"
PRINT #2, "' error code which you may trap and handle as needed with your own"
PRINT #2, "' ON ERROR GOTO... handler."
PRINT #2, "'---------------------------------------------------------------------"
PRINT #2, "FUNCTION Write"; tarName$; "Data$ (file$)"
PRINT #2, "'--- option _explicit requirements ---"
PRINT #2, "DIM po%, body$, ext$, num%, numL&, numB&, rawdata$, stroffs&, i&, dat&, ff%";
IF packed% THEN PRINT #2, ", filedata$": ELSE PRINT #2, ""
PRINT #2, "'--- separate filename body & extension ---"
PRINT #2, "FOR po% = LEN(file$) TO 1 STEP -1"
PRINT #2, " IF MID$(file$, po%, 1) = "; CHR$(34); "."; CHR$(34); " THEN"
PRINT #2, " body$ = LEFT$(file$, po% - 1)"
PRINT #2, " ext$ = MID$(file$, po%)"
PRINT #2, " EXIT FOR"
PRINT #2, " ELSEIF MID$(file$, po%, 1) = "; CHR$(34); "\"; CHR$(34); " OR MID$(file$, po%, 1) = "; CHR$(34); "/"; CHR$(34); " OR po% = 1 THEN"
PRINT #2, " body$ = file$"
PRINT #2, " ext$ = "; CHR$(34); CHR$(34)
PRINT #2, " EXIT FOR"
PRINT #2, " END IF"
PRINT #2, "NEXT po%"
PRINT #2, "'--- avoid overwriting of existing files ---"
PRINT #2, "num% = 1"
PRINT #2, "WHILE _FILEEXISTS(file$)"
PRINT #2, " file$ = body$ + "; CHR$(34); "("; CHR$(34); " + LTRIM$(STR$(num%)) + "; CHR$(34); ")"; CHR$(34); " + ext$"
PRINT #2, " num% = num% + 1"
PRINT #2, "WEND"
PRINT #2, "'--- write DATAs ---"
PRINT #2, "RESTORE "; tarName$
PRINT #2, "READ numL&, numB&"
PRINT #2, "rawdata$ = SPACE$((numL& * 4) + numB&)"
PRINT #2, "stroffs& = 1"
PRINT #2, "FOR i& = 1 TO numL&"
PRINT #2, " READ dat&"
PRINT #2, " MID$(rawdata$, stroffs&, 4) = MKL$(dat&)"
PRINT #2, " stroffs& = stroffs& + 4"
PRINT #2, "NEXT i&"
PRINT #2, "IF numB& > 0 THEN"
PRINT #2, " FOR i& = 1 TO numB&"
PRINT #2, " READ dat&"
PRINT #2, " MID$(rawdata$, stroffs&, 1) = CHR$(dat&)"
PRINT #2, " stroffs& = stroffs& + 1"
PRINT #2, " NEXT i&"
PRINT #2, "END IF"
PRINT #2, "ff% = FREEFILE"
PRINT #2, "OPEN file$ FOR OUTPUT AS ff%"
IF packed% THEN
PRINT #2, "CLOSE ff%"
PRINT #2, "filedata$ = LzwUnpack$(rawdata$)"
PRINT #2, "OPEN file$ FOR BINARY AS ff%"
PRINT #2, "PUT #ff%, , filedata$"
ELSE
PRINT #2, "PRINT #ff%, rawdata$;"
END IF
PRINT #2, "CLOSE ff%"
PRINT #2, "'--- set result ---"
PRINT #2, "Write"; tarName$; "Data$ = file$"
PRINT #2, "EXIT FUNCTION"
PRINT #2, ""
PRINT #2, "'--- DATAs representing the contents of file "; srcName$
PRINT #2, "'---------------------------------------------------------------------"
PRINT #2, tarName$; ":"
'--- read LONGs ---
PRINT #2, "DATA "; LTRIM$(STR$(cntL& * 8)); ","; LTRIM$(STR$(cntB&))
tmpI$ = SPACE$(32)
FOR z& = 1 TO cntL&
GET #1, , tmpI$: offI% = 1
tmpO$ = "DATA " + STRING$(87, ","): offO% = 6
DO
tmpL& = CVL(MID$(tmpI$, offI%, 4)): offI% = offI% + 4
MID$(tmpO$, offO%, 10) = "&H" + RIGHT$("00000000" + HEX$(tmpL&), 8)
offO% = offO% + 11
LOOP UNTIL offO% > 92
PRINT #2, tmpO$
NEXT z&
'--- read remaining BYTEs ---
IF cntB& > 0 THEN
PRINT #2, "DATA ";
FOR x% = 1 TO cntB&
GET #1, , tmpB%%
PRINT #2, "&H" + RIGHT$("00" + HEX$(tmpB%%), 2);
IF x% <> 16 THEN
IF x% <> cntB& THEN PRINT #2, ",";
ELSE
IF x% <> cntB& THEN
PRINT #2, ""
PRINT #2, "DATA ";
END IF
END IF
NEXT x%
PRINT #2, ""
END IF
PRINT #2, "END FUNCTION"
PRINT #2, ""
'--- ending ---
CLOSE #2
CLOSE #1
'--- finish message ---
COLOR 10: PRINT: PRINT "file successfully processed..."
COLOR 9: PRINT: PRINT "You must $INCLUDE the created file (target name + .bm extension) at"
PRINT "the end of your program and call the function 'Write"; tarName$; "Data$(...)'"
PRINT "in an appropriate place to write the file back to disk."
IF packed% THEN
COLOR 12: PRINT: PRINT "Your program must also $INCLUDE 'lzwpacker.bm' available from"
PRINT "the Libraries Collection here:"
PRINT " https://staging.qb64phoenix.com/forumdisplay.php?fid=23"
PRINT "to be able to write back the just processed file."
KILL tarPath$ + tar$ + ".lzw"
END IF
done:
COLOR 7
END
'--- error handler ---
abort:
COLOR 12: PRINT: PRINT "something is wrong with path/file access, check your inputs and try again..."
RESUME done
'$INCLUDE: 'QB64Library\LZW-Compress\lzwpacker.bm'
And now the second tool MakeCARR. It will do the whole thing in an array on C/C++ level, rather then in DATAs on the BASIC level. Although it's handling is a bit more tricky, as you get not only a .bm file, but also a .h file, and both must match (ie. the DECLARE LIBRARY path in the .bm must point to the .h), this approch has several advantages especially for big files:- Unless DATAs, which are included in the final EXE as written (ie. as ASCII chars), a C-Array containing numbers is embedded as (you guess) array of binary numbers, hence even uncompressed it would not take more space than the original file. This makes the compression even more valuable, as it really reduces the final EXE size, instead of just compensating the Number-to-Ascii bloat only as for the DATAs.
- As the array is stored as successive numbers in memory, it's possible to write back the entire array with just one disk access, which is much faster than reading all single DATAs and concatenate them into one big string, which is then written out.
- As the converted data is not in the included .bm file anymore (but in the .h file now), the syntax checking/compiling in the IDE will need less, depending on filesize much less time to finish, as it doesn't need to check 100s (or even 1000s) of DATA lines.
- On C/C++ level it's easy to expand the given writeback path/filename into a full qualified absolut path using a standard library call. This path/filename is returned through the writeback function and can be used in your program to always safely access the written file, doesn't matter how often you change the current working directory using the CHDIR statement.
- For any files, which are only needed temporarily during program runtime you can specify an auto-cleanup, which automatically deletes the written file again, as soon as your program terminates. This feature is also easily accessible on C/C++ level through an 'atexit()' function.
Again, if you're using at least QB64 v1.4 or any Phoenix Edition version and don't wanna use the extra Lzw packer libarary, but the QB64 built-in zlib compression instead, then simply substitute the LzwPack$ call (line 98) with the respective _DEFLATE$ call and the LzwUnpack$ call (line 312) with an _INFLATE$ call. Also delete the $INCLUDE line at the end.
MakeCARR.bas
Code: (Select All)
'+---------------+---------------------------------------------------+
'| ###### ###### | .--. . .-. |
'| ## ## ## # | | )| ( ) o |
'| ## ## ## | |--' |--. .-. -. . .-...--.--. .-. |
'| ###### ## | | \ | |( )( ) | ( || | |( ) |
'| ## ## | ' ' --' -'-' - -|' ' --' - |
'| ## ## # | ._.' |
'| ## ###### | Sources & Documents placed in the Public Domain. |
'+---------------+---------------------------------------------------+
'| |
'| === MakeCARR.bas === |
'| |
'| == Create a C/C++ array out of the given file, so you can embed |
'| == it in your program and write it back when needed. |
'| |
'| == Two files are created, the .h file, which contains the array(s)|
'| == and some functions, and a respective .bm file which needs to |
'| == be $INCLUDEd with your program and does provide the FUNCTION |
'| == to write back the array(s) into any file. All used functions |
'| == are standard library calls, no API calls are involved, so the |
'| == writeback should work on all QB64 supported platforms. |
'| |
'| == Make sure to adjust the path for the .h file for your personal |
'| == needs in the created .bm files (DECLARE LIBRARY), if required. |
'| == You may specify default paths right below this header. |
'| |
'| == This program needs the 'lzwpacker.bm' file available from the |
'| == Libraries Collection here: |
'| == https://staging.qb64phoenix.com/forumdisplay.php?fid=23 |
'| == as it will try to pack the given file to keep the array(s) as |
'| == small as possible. If compression is successful, then your |
'| == program also must $INCLUDE 'lzwpacker.bm' to be able to unpack |
'| == the file data again for write back. MakeCARR.bas is printing |
'| == a reminder message in such a case. |
'| |
'+-------------------------------------------------------------------+
'| Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |
'| Find me in the QB64 Forum or mail to support@rhosigma-cw.net for |
'| any questions or suggestions. Thanx for your interest in my work. |
'+-------------------------------------------------------------------+
'--- if you wish, set any default paths, end with a backslash ---
srcPath$ = "" 'source path
tarPath$ = "" 'target path
'-----
IF srcPath$ <> "" THEN
COLOR 15: PRINT "Default source path: ": COLOR 7: PRINT srcPath$: PRINT
END IF
IF tarPath$ <> "" THEN
COLOR 15: PRINT "Default target path: ": COLOR 7: PRINT tarPath$: PRINT
END IF
'--- collect inputs (relative paths allowed, based on default paths) ---
source:
LINE INPUT "Source Filename: "; src$ 'any file you want to put into a C/C++ array
IF src$ = "" GOTO source
target:
LINE INPUT "Target Basename: "; tar$ 'write stuff into this file(s) (.h/.bm is added)
IF tar$ = "" GOTO target
'-----
ON ERROR GOTO abort
OPEN "I", #1, srcPath$ + src$: CLOSE #1 'file exist check
OPEN "O", #2, tarPath$ + tar$ + ".bm": CLOSE #2 'path exist check
ON ERROR GOTO 0
'--- separate source filename part ---
FOR po% = LEN(src$) TO 1 STEP -1
IF MID$(src$, po%, 1) = "\" OR MID$(src$, po%, 1) = "/" THEN
srcName$ = MID$(src$, po% + 1)
EXIT FOR
ELSEIF po% = 1 THEN
srcName$ = src$
END IF
NEXT po%
'--- separate target filename part ---
FOR po% = LEN(tar$) TO 1 STEP -1
IF MID$(tar$, po%, 1) = "\" OR MID$(tar$, po%, 1) = "/" THEN
tarName$ = MID$(tar$, po% + 1)
EXIT FOR
ELSEIF po% = 1 THEN
tarName$ = tar$
END IF
NEXT po%
MID$(tarName$, 1, 1) = UCASE$(MID$(tarName$, 1, 1)) 'capitalize 1st letter
'---------------------------------------------------------------------
' Depending on the source file's size, one or more array(s) are
' created. This is because some C/C++ compilers seem to have problems
' with arrays with more than 65535 elements. This does not affect the
' write back, as the write function will take this behavior into account.
'---------------------------------------------------------------------
'--- init ---
OPEN "B", #1, srcPath$ + src$
filedata$ = SPACE$(LOF(1))
GET #1, , filedata$
CLOSE #1
rawdata$ = LzwPack$(filedata$, 20)
IF rawdata$ <> "" THEN
OPEN "O", #1, tarPath$ + tar$ + ".lzw"
CLOSE #1
OPEN "B", #1, tarPath$ + tar$ + ".lzw"
PUT #1, , rawdata$
CLOSE #1
packed% = -1
OPEN "B", #1, tarPath$ + tar$ + ".lzw"
ELSE
packed% = 0
OPEN "B", #1, srcPath$ + src$
END IF
fl& = LOF(1)
cntL& = INT(fl& / 32)
cntV& = INT(cntL& / 8180)
cntB& = (fl& - (cntL& * 32))
'--- .h include file ---
OPEN "O", #2, tarPath$ + tar$ + ".h"
PRINT #2, "// ============================================================"
PRINT #2, "// === This file was created with MakeCARR.bas by RhoSigma, ==="
PRINT #2, "// === use it in conjunction with its respective .bm file. ==="
PRINT #2, "// ============================================================"
PRINT #2, ""
PRINT #2, "// --- Array(s) representing the contents of file "; srcName$
PRINT #2, "// ---------------------------------------------------------------------"
'--- read LONGs ---
tmpI$ = SPACE$(32)
FOR vc& = 0 TO cntV&
IF vc& = cntV& THEN numL& = (cntL& MOD 8180): ELSE numL& = 8180
PRINT #2, "static const uint32_t "; tarName$; "L"; LTRIM$(STR$(vc&)); "[] = {"
PRINT #2, " "; LTRIM$(STR$(numL& * 8)); ","
FOR z& = 1 TO numL&
GET #1, , tmpI$: offI% = 1
tmpO$ = " " + STRING$(88, ","): offO% = 5
DO
tmpL& = CVL(MID$(tmpI$, offI%, 4)): offI% = offI% + 4
MID$(tmpO$, offO%, 10) = "0x" + RIGHT$("00000000" + HEX$(tmpL&), 8)
offO% = offO% + 11
LOOP UNTIL offO% > 92
IF z& < numL& THEN PRINT #2, tmpO$: ELSE PRINT #2, LEFT$(tmpO$, 91)
NEXT z&
PRINT #2, "};"
PRINT #2, ""
NEXT vc&
'--- read remaining BYTEs ---
IF cntB& > 0 THEN
PRINT #2, "static const uint8_t "; tarName$; "B[] = {"
PRINT #2, " "; LTRIM$(STR$(cntB&)); ","
PRINT #2, " ";
FOR x% = 1 TO cntB&
GET #1, , tmpB%%
PRINT #2, "0x" + RIGHT$("00" + HEX$(tmpB%%), 2);
IF x% <> 16 THEN
IF x% <> cntB& THEN PRINT #2, ",";
ELSE
IF x% <> cntB& THEN
PRINT #2, ","
PRINT #2, " ";
END IF
END IF
NEXT x%
PRINT #2, ""
PRINT #2, "};"
PRINT #2, ""
END IF
'--- some functions ---
PRINT #2, "// --- Saved full qualified output path and filename, so we've no troubles"
PRINT #2, "// --- when cleaning up, even if the current working folder was changed"
PRINT #2, "// --- during program runtime."
PRINT #2, "// ---------------------------------------------------------------------"
PRINT #2, "char "; tarName$; "Name[8192]; // it's a safe size for any current OS"
PRINT #2, ""
PRINT #2, "// --- Cleanup function to delete the written file, called by the atexit()"
PRINT #2, "// --- handler at program termination time, if requested by user."
PRINT #2, "// ---------------------------------------------------------------------"
PRINT #2, "void Kill"; tarName$; "Data(void)"
PRINT #2, "{"
PRINT #2, " remove("; tarName$; "Name);"
PRINT #2, "}"
PRINT #2, ""
PRINT #2, "// --- Function to write the array(s) back into a file, will return the"
PRINT #2, "// --- full qualified output path and filename on success, otherwise an"
PRINT #2, "// --- empty string is returned (access/write errors, file truncated)."
PRINT #2, "// ---------------------------------------------------------------------"
PRINT #2, "const char *Write"; tarName$; "Data(const char *FileName, int16_t AutoClean)"
PRINT #2, "{"
PRINT #2, " FILE *han = NULL; // file handle"
PRINT #2, " int32_t num = NULL; // written elements"
PRINT #2, ""
PRINT #2, " #ifdef QB64_WINDOWS"
PRINT #2, " if (!_fullpath("; tarName$; "Name, FileName, 8192)) return "; CHR$(34); CHR$(34); ";"
PRINT #2, " #else"
PRINT #2, " if (!realpath(FileName, "; tarName$; "Name)) return "; CHR$(34); CHR$(34); ";"
PRINT #2, " #endif"
PRINT #2, ""
PRINT #2, " if (!(han = fopen("; tarName$; "Name, "; CHR$(34); "wb"; CHR$(34); "))) return "; CHR$(34); CHR$(34); ";"
PRINT #2, " if (AutoClean) atexit(Kill"; tarName$; "Data);"
PRINT #2, ""
FOR vc& = 0 TO cntV&
PRINT #2, " num = fwrite(&"; tarName$; "L"; LTRIM$(STR$(vc&)); "[1], 4, "; tarName$; "L"; LTRIM$(STR$(vc&)); "[0], han);"
PRINT #2, " if (num != "; tarName$; "L"; LTRIM$(STR$(vc&)); "[0]) {fclose(han); return "; CHR$(34); CHR$(34); ";}"
PRINT #2, ""
NEXT vc&
IF cntB& > 0 THEN
PRINT #2, " num = fwrite(&"; tarName$; "B[1], 1, "; tarName$; "B[0], han);"
PRINT #2, " if (num != "; tarName$; "B[0]) {fclose(han); return "; CHR$(34); CHR$(34); ";}"
PRINT #2, ""
END IF
PRINT #2, " fclose(han);"
PRINT #2, " return "; tarName$; "Name;"
PRINT #2, "}"
PRINT #2, ""
'--- ending ---
CLOSE #2
CLOSE #1
'--- .bm include file ---
OPEN "O", #2, tarPath$ + tar$ + ".bm"
PRINT #2, "'============================================================"
PRINT #2, "'=== This file was created with MakeCARR.bas by RhoSigma, ==="
PRINT #2, "'=== you must $INCLUDE this at the end of your program. ==="
IF packed% THEN
PRINT #2, "'=== ---------------------------------------------------- ==="
PRINT #2, "'=== If your program is NOT a GuiTools based application, ==="
PRINT #2, "'=== then it must also $INCLUDE: 'lzwpacker.bm' available ==="
PRINT #2, "'=== from the Libraries Collection here: ==="
PRINT #2, "'=== https://staging.qb64phoenix.com/forumdisplay.php?fid=23 ==="
END IF
PRINT #2, "'============================================================"
PRINT #2, ""
PRINT #2, "'-----------------"
PRINT #2, "'--- Important ---"
PRINT #2, "'-----------------"
PRINT #2, "' If you need to move around this .bm file and its respective .h file"
PRINT #2, "' to fit in your project, then make sure the path in the DECLARE LIBRARY"
PRINT #2, "' statement below does match the actual .h file location. It's best to"
PRINT #2, "' specify a relative path assuming your QB64 installation folder as root."
PRINT #2, "'---------------------------------------------------------------------"
PRINT #2, ""
'--- writeback function ---
PRINT #2, "'"; STRING$(LEN(tarName$) + 19, "-")
PRINT #2, "'--- Write"; tarName$; "Array$ ---"
PRINT #2, "'"; STRING$(LEN(tarName$) + 19, "-")
PRINT #2, "' This function will write the array(s) you've created with MakeCARR.bas"
PRINT #2, "' back to disk and so it rebuilds the original file."
PRINT #2, "'"
PRINT #2, "' After the writeback call, only use the returned realFile$ to access the"
PRINT #2, "' written file. It's the full qualified absolute path and filename, which"
PRINT #2, "' is made by expanding your maybe given relative path and an maybe altered"
PRINT #2, "' filename (number added) in order to avoid the overwriting of an already"
PRINT #2, "' existing file with the same name in the given location. By this means"
PRINT #2, "' you'll always have safe access to the file, no matter how your current"
PRINT #2, "' working folder changes during runtime."
PRINT #2, "'"
PRINT #2, "' If you wish, the written file can automatically be deleted for you when"
PRINT #2, "' your program will end, so you don't need to do the cleanup yourself."
PRINT #2, "'----------"
PRINT #2, "' SYNTAX:"
PRINT #2, "' realFile$ = Write"; tarName$; "Array$ (wantFile$, autoDel%)"
PRINT #2, "'----------"
PRINT #2, "' INPUTS:"
PRINT #2, "' --- wantFile$ ---"
PRINT #2, "' The filename you would like to write the array(s) to, can contain"
PRINT #2, "' a full or relative path."
PRINT #2, "' --- autoDel% ---"
PRINT #2, "' Shows whether you want the auto cleanup (see description above) at"
PRINT #2, "' the program end or not (-1 = delete file, 0 = don't delete file)."
PRINT #2, "'----------"
PRINT #2, "' RESULT:"
PRINT #2, "' --- realFile$ ---"
PRINT #2, "' - On success this is the full qualified path and filename finally"
PRINT #2, "' used after all applied checks, use only this returned filename"
PRINT #2, "' to access the written file."
PRINT #2, "' - On failure (write/access) this will be an empty string, so you"
PRINT #2, "' should check for this before trying to access/open the file."
PRINT #2, "'---------------------------------------------------------------------"
PRINT #2, "FUNCTION Write"; tarName$; "Array$ (file$, clean%)"
PRINT #2, "'--- declare C/C++ function ---"
PRINT #2, "DECLARE LIBRARY "; CHR$(34); tarPath$; tar$; CHR$(34); " 'Do not add .h here !!"
PRINT #2, " FUNCTION Write"; tarName$; "Data$ (FileName$, BYVAL AutoClean%)"
PRINT #2, "END DECLARE"
PRINT #2, "'--- option _explicit requirements ---"
PRINT #2, "DIM po%, body$, ext$, num%";
IF packed% THEN PRINT #2, ", real$, ff%, rawdata$, filedata$": ELSE PRINT #2, ""
PRINT #2, "'--- separate filename body & extension ---"
PRINT #2, "FOR po% = LEN(file$) TO 1 STEP -1"
PRINT #2, " IF MID$(file$, po%, 1) = "; CHR$(34); "."; CHR$(34); " THEN"
PRINT #2, " body$ = LEFT$(file$, po% - 1)"
PRINT #2, " ext$ = MID$(file$, po%)"
PRINT #2, " EXIT FOR"
PRINT #2, " ELSEIF MID$(file$, po%, 1) = "; CHR$(34); "\"; CHR$(34); " OR MID$(file$, po%, 1) = "; CHR$(34); "/"; CHR$(34); " OR po% = 1 THEN"
PRINT #2, " body$ = file$"
PRINT #2, " ext$ = "; CHR$(34); CHR$(34)
PRINT #2, " EXIT FOR"
PRINT #2, " END IF"
PRINT #2, "NEXT po%"
PRINT #2, "'--- avoid overwriting of existing files ---"
PRINT #2, "num% = 1"
PRINT #2, "WHILE _FILEEXISTS(file$)"
PRINT #2, " file$ = body$ + "; CHR$(34); "("; CHR$(34); " + LTRIM$(STR$(num%)) + "; CHR$(34); ")"; CHR$(34); " + ext$"
PRINT #2, " num% = num% + 1"
PRINT #2, "WEND"
PRINT #2, "'--- write array & set result ---"
IF NOT packed% THEN
PRINT #2, "Write"; tarName$; "Array$ = Write"; tarName$; "Data$(file$ + CHR$(0), clean%)"
ELSE
PRINT #2, "real$ = Write"; tarName$; "Data$(file$ + CHR$(0), clean%)"
PRINT #2, "IF real$ <> "; CHR$(34); CHR$(34); " THEN"
PRINT #2, " ff% = FREEFILE"
PRINT #2, " OPEN real$ FOR BINARY AS ff%"
PRINT #2, " rawdata$ = SPACE$(LOF(ff%))"
PRINT #2, " GET #ff%, , rawdata$"
PRINT #2, " filedata$ = LzwUnpack$(rawdata$)"
PRINT #2, " PUT #ff%, 1, filedata$"
PRINT #2, " CLOSE ff%"
PRINT #2, "END IF"
PRINT #2, "Write"; tarName$; "Array$ = real$"
END IF
PRINT #2, "END FUNCTION"
PRINT #2, ""
'--- ending ---
CLOSE #2
'--- finish message ---
COLOR 10: PRINT: PRINT "file successfully processed..."
COLOR 9: PRINT: PRINT "You must $INCLUDE the created file (target name + .bm extension) at"
PRINT "the end of your program and call the function 'Write"; tarName$; "Array$(...)'"
PRINT "in an appropriate place to write the file back to disk."
IF packed% THEN
COLOR 12: PRINT: PRINT "Your program must also $INCLUDE 'lzwpacker.bm' available from"
PRINT "the Libraries Collection here:"
PRINT " https://staging.qb64phoenix.com/forumdisplay.php?fid=23"
PRINT "to be able to write back the just processed file."
KILL tarPath$ + tar$ + ".lzw"
END IF
done:
COLOR 7
END
'--- error handler ---
abort:
COLOR 12: PRINT: PRINT "something is wrong with path/file access, check your inputs and try again..."
RESUME done
'$INCLUDE: 'QB64Library\LZW-Compress\lzwpacker.bm'
|
|
|
under linux Program Console BUG |
Posted by: Coolman - 05-26-2022, 08:37 PM - Forum: General Discussion
- Replies (10)
|
|
i made a console program ($Console:Only) that should run in a terminal. it seems that when executing a console program, the current directory is the one of the executable. the _CWD$ function confirms it.
|
|
|
DRAGON CAVE |
Posted by: James D Jarvis - 05-26-2022, 01:12 PM - Forum: Works in Progress
- No Replies
|
|
here's a wumpus-a-like I've been fiddling with. A simple treasure hunting/dragon slaying adventure. Simple text or choice base input control.
All planned features aren't in place yet but it's moving along.
Code: (Select All) 'dragon cave
'
'A wumpus-a-like by James D. Jarvis may,2022
'
_Title "D R A G O N C A V E"
Randomize Timer
Dim Shared cave(30, 9), cd$(50), pcl, score, havehearthstone, gd, gold
Dim Shared lootd$(8)
Dim Shared monster$(7)
Const pnorth = 1: Const peast = 3: Const psouth = 2: Const pwest = 4: Const pup = 5: Const pdown = 6
Const foe = 7: Const loot = 8: Const desc = 9
Dim Shared vigor, luck, perception, stealth, magic, arrows
Dim Shared maxvigor, maxluck, maxperception, maxstealth, maxmagic
Dim Shared dragonstate As Integer
Dim Shared spellheal, spellrabbitfoot, spellblast, spelloracle
load_cavedesc
load_monsters
load_loot
playagain:
score = 0
havehearthstone = 0
Cls
Print "D R A G O N C A V E"
Print
Print "Your quest is a simple one, seek the HearthStone and return it the Iron Dwarves."
Print ""
Print "Simple enough really, except for the dragon of course ..."
Print ""
Print "You have 3 magic arrows to defend yourself but be careful..."
Print "... as the Dragon is not alone."
Print " "
Print "<enter to continue>": Input any$
build_Player
show_scores
build_caves
pcl = droll(1, 10)
Print "<enter to continue>": Input any$
Cls
Print "The dwarves lower you deep into the caves, drawing back the line and sealing the way above"
Print "so the dragon can not escape through that route and catch them unaware."
Print "You will have to discover your own route out."
Print "<enter to continue>": Input any$
Do
Print
Print "====================================================================="
Print cd$(cave(pcl, desc))
Print "====================================================================="
Print " "
If cave(pcl, foe) > 0 Then
Print "There is a "; monster$(cave(pcl, foe)); " in this cave."
Print " "
End If
onward:
Print pickprompt$;: Input ask$
ask$ = LCase$(ask$)
ask$ = truncate$(ask$)
Select Case ask$
Case "scores", "stats", "abilities", "show scores", "show stats", "show abilities": show_scores
Case "score", "show score", "show": show_scores
Case "look", "search": do_look
Case "n", "north", "go n", "go north", "walk n", "walk north": go_passage pnorth, "walk"
Case "e", "east", "go e", "go east", "walk e", "walk east": go_passage peast, "walk"
Case "s", "south", "go s", "go south", "walk s", "walk south": go_passage psouth, "walk"
Case "w", "west", "go west", "go west", "walk west", "walk west": go_passage pwest, "walk"
Case "u", "up", "go u", "go up", "climb u", "climb up": go_passage pup, "climb"
Case "d", "down", "go d", "go down", "climb d", "climb down": go_passage pdown, "climb"
Case "run north", "run n": go_passage pnorth, "run"
Case "run south", "run s": go_passage psouth, "run"
Case "run south", "run e": go_passage peast, "run"
Case "run south", "run w": go_passage pwest, "run"
Case "jump up", "leap up", "hop up", "jump u", "leap u", "leap up": go_passage pup, "jump"
Case "jump down", "leap down", "hop down", "jump d", "leap down", "leap d": go_passage pdown, "jump"
Case "hit", "kill", "strike", "slay", "attack", "stab": attack
Case "shoot", "fire": shootarrow 0
Case "shootnorth": shootarrow pnorth
Case "shootsouth": shootarrow psouth
Case "shooteast": shootarrow peast
Case "shootwest": shootarrow pwest
Case "shootup": shootarrow pup
Case "shootdown": shootarrow pdown
Case "castblast": cast_spell "castblast"
Case "castheal": cast_spell "castheal"
Case "castrabbit": cast_spell "castrabbit"
Case "castoracle": cast_spell "castoracle"
Case "listen": do_listen
Case "sniff", "smell": do_smell
Case "get", "fetch", "pickup", "pick-up", "pick up", "grab": get_loot
Case "help", "h", "?": show_help
End Select
If cave(pcl, foe) > 0 And droll(1, 8) < cave(pcl, foe) Then
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "The "; monster$(cave(pcl, foe)); " attacks you."
Print
mattack = droll(1, 20) + cave(pcl, foe)
If mattack > vigor Then
di = droll(1, cave(pcl, foe))
Print "It strikes you for "; di; " points of damage "
vigor = vigor - di
Print
Else
ar = droll(1, 3)
Select Case ar
Case 1: Print "You narrowly avoid the blow."
Case 2: Print "It fails to stike you."
Case 3: Print "You parry the atatck."
End Select
Print
End If
End If
If cave(pcl, foe) < 0 And droll(1, 4) < cave(pcl, foe) Then
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
cave(pcl, foe) = Abs(cave(pcl, foe))
Print "A "; monster$(cave(pcl, foe)); " attempts to ambush you."
Print
mattack = droll(2, 20) + cave(pcl, foe)
If mattack > vigor + luck Then
di = droll(1, cave(pcl, foe))
Print "It strikes you for "; di; " points of damage "
vigor = vigor - di
Print
Else
luck = luck + 1
If luck > maxluck Then luck = maxluck
Print "You avoid it's attack"
Print
End If
End If
If vigor > 0 And vigor < 4 Then
Print
wr = droll(1, 3)
Select Case wr
Case 1: Print "You are exhausted..."
Case 2: Print "You feel weak..."
Case 3: Print "You are battered and bruised..."
End Select
lcheck = droll(1, 20)
If lcheck < luck Then
If luck < maxluck Then luck = luck + 1
Print "... but you pull through for now."
Else
luck = luck - (droll(1, 2) - 1)
Print " ..."
Sleep 0.25
Print " .... "
Sleep 0.25
Print " ..... you collapse."
End If
If Abs(cave(pcl, foe)) > 0 And droll(1, 100) > luck Then
cave(pcl, foe) = Abs(cave(pcl, foe))
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print " "
Print "The "; monster$(cave(pcl, foe)); " mauls you while you are down."
Print " "
di = droll(1, cave(pcl, foe))
Print "It harms you for "; di; " points of damage "
vigor = vigor - di
Print
Print "<enter to continue>": Input any$
End If
End If
If vigor < 1 Then
Print "! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !"
Print "-----------------------------------------------------------"
Print "! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !"
Print " "
dm = droll(1, 4)
Select Case dm
Case 1: Print " YOU HAVE BEEN VANQUISHED !"
Case 2: Print " YOU HAVE DIED !"
Case 3: Print " YOU HAVE FALLEN DUE TO YOUR WOUNDS !"
Case 4: Print " THE LAST THING YOU HEAR A DRAGONS ROAR !"
End Select
Print
Print "! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !"
Print "-----------------------------------------------------------"
Print "! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !"
ask$ = "quit"
End If
Loop Until ask$ = "quit"
Print
Sleep 0.25
Print " G A M E O V E R"
Print
Print "Final Score : "; score
Print
Print "play again";: Input A$
A$ = LCase$(A$)
If A$ = "y" Or A$ = "yes" Then GoTo playagain
cavedata:
Data 0,2,0,0,0,0,0,0,0: '1
Data 1,0,4,0,0,0,0,0,0: '2
Data 0,4,5,0,0,0,0,0,0: '3
Data 3,0,0,2,0,0,0,0,0: '4
Data 0,6,0,3,0,0,0,0,0: '5
Data 5,0,8,0,0,0,0,0,0: '6
Data 0,8,9,0,0,0,0,0,0: '7
Data 7,0,0,6,0,0,0,0,0: '8
Data 0,11,10,7,0,0,0,0,0: '9
Data 0,0,0,9,0,0,0,0,0: '10
Data 9,0,12,0,0,0,0,0,0: '11
Data 0,13,0,11,0,0,0,0,0: '12
Data 12,15,0,0,0,0,0,0,0: '13
Data 0,0,15,0,0,0,0,0,0: '14
Data 13,16,0,14,0,0,0,0,0: '15
Data 15,0,0,17,0,0,0,0,0: '16
Data 0,22,16,18,0,0,0,0,0: '17
Data 0,0,17,19,0,0,0,0,0: '18
Data 0,20,18,0,0,0,0,0,0: '19
Data 19,24,21,0,0,0,0,0,0: '20
Data 0,0,0,20,0,0,0,0,0: '21
Data 17,0,23,0,0,0,0,0,0: '22
Data 0,0,0,22,0,0,0,0,0: '23
Data 20,25,0,0,0,0,0,0,0: '24
Data 24,0,0,26,0,0,0,0,0: '25
Data 0,27,25,0,0,0,0,0,0: '26
Data 26,29,28,0,0,0,0,0,0: '27
Data 0,0,0,27,0,0,0,0,0: '28
Data 27,0,30,0,0,0,0,0,0: '29
Data 0,0,0,29,0,0,0,0,0: '30
cavedescdata:
Data "Musty cave"
Data "Cramped cave"
Data "Muddy cave"
Data "Bubbling pool of mud."
Data "Rancid pool of water."
Data "Dripping stalactities."
Data "Slippery sloped cave."
Data "Mineshaft."
Data "Crumbling old mineshaft."
Data "Mushroom garden."
Data "Fungus forest."
Data "Gloomy grotto."
Data "Dry cave."
Data "Cramped dusty cave."
Data "Mold encrusted walls."
Data "Carpeted in black mold."
Data "Floor covered in slime."
Data "Waist deep guano."
Data "Piles of guano crawling with vermin."
Data "Bottomles pit."
Data "Precarious bridge across a chasm."
Data "Chasm edge, no bottom in sight."
Data "Lava lake."
Data "Stream of lava splitting the chamber north and south."
Data "Lava flow splitting the chamber east and west."
Data "Bubbling pool of lava."
Data "Damp cave."
Data "Cavern choked with cave clams."
Data "Slime pit."
Data "Snake pit."
Data "Worm pit."
Data "Bone pit."
Data "Lava pit."
Data "Steamy cave."
Data "Cold cave."
Data "Ice Cave."
Data "Dusty cave."
Data "Cave full of crumbling pillars."
Data "Unearthy crytsal grotto."
Data "Pool of darkness."
Data "Hall of echoes."
Data "Heart of darkness."
Data "Ancient dwarf crypt."
Data "Ancient dwarf warehouse."
Data "Cold dwarven forge."
Data "Shattered dwarven throne."
Data "Cave littered with shards of dragon eggs."
Data "An old dragon nest."
Data "A fresh dragon nest."
Data "Dragon hoard."
monsterdata:
Data "Bat",
Data "Cavewight"
Data "Huge Bat"
Data "Molebear"
Data "Cave Clam"
Data "Shroombie"
Data "Dragon"
lootdata:
Data "Gold Nugget"
Data "Gold Coins"
Data "Gold Ingot"
Data "Healing Rune"
Data "Rabbit's Foot Rune"
Data "Blast Rune"
Data "Oracle Rune"
Data "HearthStone"
Sub heading_out
Print " TO THE SURFACE ..."
Print
Print " ... "
Sleep 0.25
If havehearthstone = 0 Then
Print "But you lack the HearthStone"
Print
Print "Turn back? <Y,N>"
Input A$
If LCase$(A$) = "yes" Or LCase$(A$) = "y" Then
ask$ = ""
gd = 0
Print " "
Print "back to..."
Print
Else
keepaskinghere:
Print "- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -"
Print "How are yuo going to handle this situation?"
Print "1 - Sneak past the Iron dwarves?"
Print "2 - Tell them you quit."
Print "3 - Run away !"
Print "4- Challneg the king of the Iron Dwarves to single combat!"
Print
Print "Make yuor selection"
Input AA
If AA < 1 Or AA > 4 Then GoTo keepaskinghere
Select Case AA
Case 1:
If droll(1, 20) < luck Then
Print "You slip past the Iron Dwarves to go live your life in peace."
gd = 0
ask$ = "quit"
Else
Print
Print "The Dwarves grab you and give you a sound thrashing..."
Print " "
Print "'YOU AREN'T GETING OUT IF THIS DEAL SO EASY!'"
Print
Print "They toss you back in the caves."
Print
Sleep 0.25
vigor = vigor - droll(1, 4)
gd = 0
ask$ = ""
End If
Case 2:
Print "The dwarves ponder your request..."
Print
Sleep 0.25
If droll(1, 30) < luck Then
Print "Okay we'll let you off the hook..."
If droll(1, 20) < luck Then
Print "...the dwarves let yuo break tyour contract and live yuor life in peace."
gd = 0
ask$ = "quit"
Else
Print "...the dwarves rough yuo up and sieze your loot for being a coward."
gold = 0
score = score / 2
gd = 0
ask$ = "quit"
End If
Else
Print " "
Print "The Iron Dwarves laugh at you and send yuo back into the caves."
gd = 0
ask$ = ""
End If
Case 3:
Print "... Well that was easy..."
Print " "
Print "You are way too fast for the Iron dwarves to catch you, for now..."
Print
gd = 0
ask$ = "quit"
Case 4:
Print " "
Print "The dwarves all laugh at you and push yuo back into the caves."
Print " "
Sleep 0.25
gd = 0
ask$ = ""
End Select
End If
End If
If havehearthstone = 1 Then
Print
Print "YOU HAVE MADE IT OUT OF THE CAVES WITH THE HEARTHSTONE !!!"
Print
Print "What now?"
Print
Print "1 - Hand the HearhtStone over to the Iron Dwarves."
Print "2 - Sneak Away with the HearthStone."
Print "3 - Demand a larger reward."
Print
askhere2:
Input AA
If AA < 0 Or AA > 3 Then GoTo askhere2
Select Case AA
Case 1
Print " "
Print "There is much rejoicing !!!"
Print " "
Print " you are fairly rewarded and welcome in the hall sof the Iron Dwarves for the remainder off all yuor days."
Print
score = score + 1000
gold = gold + 500
gd = 0
ask$ = "quit"
Case 2
If droll(1, 30) < luck Then
Print
Print "You manage to slip past the Iro Dwarves..."
Print
Sleep 0.25
Print "Yuo find a byer for the HearhtStone in Skullport."
Print "If the Iron Dwarves ever find you it will not be pretty."
gold = gold + 5000
score = score + 500
gd = 0
ask$ = "quit"
Else
Print " "
Print "THIEF!!!"
Print
Print " .... COWARD ...."
Print
Print " ...VILLAIN!"
Print
Sleep 0.25
Print "The dwarves put you to the sword for your treachery."
gold = 0
score = score / 10
gd = 0
ask$ = "quit"
End If
Case 3
Print " "
Print "The Iron Dwarves all laugh at you..."
Print
Print "... they take the HearthStone and send you on your way."
Print
score = score + 100
gd = 0
ask$ = "quit"
End Select
End If
End Sub
Sub load_cavedesc
Restore cavedescdata
For c = 1 To 50
Read cd$(c)
Next c
End Sub
Sub do_look
Print
Print "====================================================================="
Print cd$(cave(pcl, desc))
Print "====================================================================="
Print " "
pcheck = droll(1, 12)
pcheck2 = droll(1, 20)
pcheck3 = droll(1, 24)
If pcheck <= perception Then
Print "There are exits:"
If cave(pcl, pnorth) > 0 Then Print "North"
If cave(pcl, psouth) > 0 Then Print "South"
If cave(pcl, peast) > 0 Then Print "East"
If cave(pcl, pwest) > 0 Then Print "West"
If cave(pcl, pup) > 0 Then Print "Up"
If cave(pcl, pdown) > 0 Then Print "Down"
Else
Print "The darkness keeps you from seeing much else."
End If
If pcheck2 <= perception And cave(pcl, foe) < 0 Then
Print "There is a "; monster$(Abs(cave(pcl, foe))); " hiding in here."
End If
If cave(pcl, loot) < 0 And cave(pcl, foe) = 0 Then
If pcheck3 < perception Then
cave(pcl, loot) = Abs(cave(pcl, loot))
Print "You discover a "; lootd$(cave(pcl, loot)); "."
End If
End If
If cave(pcl, loot) > 0 And pcheck3 / 2 < perception Then
Print "There is a "; lootd$(cave(pcl, loot)); " in this cave."
End If
End Sub
Sub load_loot
Restore lootdata
For x = 1 To 8
Read lootd$(x)
Next x
End Sub
Function pickprompt$
Dim pp$(4)
pp$(1) = "What now"
pp$(2) = "Choose your action"
pp$(3) = "What now burglar"
pp$(4) = "Be careful"
p = droll(1, 4)
pickprompt$ = pp$(p)
End Function
Sub build_caves
Restore cavedata
For c = 1 To 30
Read cave(c, 1), cave(c, 2), cave(c, 3), cave(c, 4), cave(c, 5), cave(c, 6), cave(c, 7), cave(c, 8), cave(c, 9)
Select Case c
Case 1, 2, 3, 4, 5, 6, 7, 8, 9, 10: cave(c, 9) = droll(1, 20)
Case 11, 12, 13, 14, 15, 16, 16, 18, 19, 20: cave(c, 9) = droll(1, 40)
Case 21, 22, 23, 24, 25: cave(c, 9) = droll(1, 20) + 20
Case 26, 27, 28, 29, 30: cave(c, 9) = droll(1, 10) + 40
End Select
mr = droll(1, 20) - droll(1, 20)
If mr < -6 Or mr > 6 Then mr = 0
cave(c, foe) = mr
tr = droll(1, 16) - droll(1, 16)
If tr < -7 Or tr > 7 Then tr = 0
cave(c, loot) = tr
For x = 1 To 6
If cave(c, x) = 0 And droll(1, 6) > 5 Then
If c < 20 Then
nr = droll(1, 24)
cave(c, x) = nr
End If
If c > 19 Then
nr = droll(1, 15) + 15
cave(c, x) = nr
End If
End If
Next x
Next c
dragonlocation = droll(1, 10) + 20
heartstonelocation = droll(1, 10) + 20
cave(hearstone, loot) = 8
cave(dragonlocation, foe) = 7
exitlocation = droll(1, 6)
cave(exitlocation, dup) = 99
End Sub
Sub load_monsters
Restore monsterdata
For x = 1 To 7
Read monster$(x)
Next x
End Sub
Sub do_listen
pr = roll(1, 20) + perception
If pr > 10 And cave(pcl, foe) < 0 Then
cave(pcl, foe) = Abs(cave(pcl, foe))
Print "? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?"
Print "You hear a "; monster$(cave(pcl, foe)); " lurking in the shadows."
Print
Sleep 0.25
End If
If pr > 20 Then
Print "? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?"
For x = 1 To 6
If cave(pcl, x) > 0 Then
cn = Abs(cave(pcl, x))
Select Case x
Case 1
If cave(cn, foe) > 0 Then Print "Something stirs to the north."
Case 2
If cave(cn, foe) > 0 Then Print "There is a tiny noise to the south."
Case 3
If cave(cn, foe) > 0 Then Print "You hear whispers to the east."
Case 4
If cave(cn, foe) > 0 Then Print "The faintest of clamors can be heard to the west."
Case 5
If cave(cn, foe) > 0 Then Print "Steps from above can be heard."
Case 6
If cave(cn, foe) > 0 Then Print "A stir of echoes wafts up fron beneath you."
End Select
End If
Next x
End If
End Sub
Sub show_help
Cls
Print "DRAGON CAVE HELP"
Print "----------------------"
Print "This game uses simple text commands."
Print "Valid commands include the directions: north,south,east,west,up, and down."
Print "you can try to sneak, walk, go, run, climb, or jump as applicable."
Print "shoot, cast <spell name>, attack, hit, and such are valid as well."
Print "with some minor variations here and there."
Print
Print "Don't foget to search, look, listen, and sniff."
Print
Sleep 0.25
End Sub
Sub do_smell
dragonflag$ = "no"
Print "--------------- Sniff, sniff -------------"
Print
If droll(1, 16) < perception Then
If cave(pcl, foe) = -7 Then Print "You smell The Dragon nearby."
For x = 1 To 6
If cave(pcl, x) > 0 Then
cn = cave(pcl, x)
If Abs(cave(cn, foe)) = 7 Then Print "You smell The Dragon nearby."
End If
Next x
End If
End Sub
Sub get_loot
If cave(pcl, loot) > 0 Then
Print "+ + + + + + + + + + + + + + + + + + + + +"
Print
Print "You fetch the "; lootd$(cave(pcl, loot))
Print
Select Case cave(pcl, loot)
Case 1
cave(pcl, loot) = 0
gold = gold + droll(1, 4)
Case 2
cave(pcl, loot) = 0
gold = gold + droll(2, 10)
Case 3
cave(pcl, loot) = 0
gold = gold + droll(2, 20) * 5
Case 4
cave(pcl, loot) = 0
If spellheal = 0 Then
spellheal = 4
Beep
Print "\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/"
Print " You have learned the Heal Spell"
Print "/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\"
Else
If spellheal > 1 Then spellheal = spellheal - 1
End If
score = score + 250
Case 5
cave(pcl, loot) = 0
If spellrabbitfoot = 0 Then
spellrabbitfoot = droll(2, 3)
Beep
Print "\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/"
Print " You have learned the Rabbit's Foot Spell"
Print "/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\"
Else
If spellrabbitfoot > 1 Then spellrabbitfoot = spellrabbitfoot - 1
End If
score = score + 250
Case 6
cave(pcl, loot) = 0
If spellblast = 0 Then
spellbalst = 4
Beep
Print "\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/"
Print " You have learned the Blast Spell"
Print "/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\"
Else
If spellblast > 1 Then spellblast = spellblast - 1
End If
score = score + 250
Case 7
cave(pcl, loot) = 0
If spelloracle = 0 Then
spelloracle = 4
Beep
Print "\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/"
Print " You have learned the Orcacle Spell"
Print "/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\"
Else
If spelloracle > 1 Then spelloracle = spelloracle - 1
End If
score = score + 250
Case 8
cave(pcl, loot) = 0
havehearthstone = 1
score = score + 2000
Print "+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+"
Print " YOU HAVE THE HEARTHSTONE, SEEK THE EXIT"
Print "+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+"
End Select
End If
End Sub
Sub attack
par = vigor + droll(2, 6)
md = cave(pcl, foe)
mdr = droll(3, md) + droll(1, 12)
If cave(pcl, foe) = 0 Then
huh = droll(1, 3)
Print "? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?"
Print
Select Case huh
Case 1: Print "There is nothing there."
Case 2: Print "The air nimbly dodges your blow."
Case 3: Print "You attack the darkness."
End Select
Print
Print "? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ?"
Print
Else
If par > mdr Then
Print "! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !"
Print
Print "You hit the "; monster$(Abs(cave(pcl, foe))); " ..."
Sleep 0.25
lr = luck - droll(1, 20)
If lr > 0 Then
score = score + Abs(cave(pcl, foe)) * 100
Print " S L A Y I N G I T ! "
Print
cave(pcl, foe) = 0
Else
score = score + Abs(cave(pcl, foe)) * 5
Print " forcing it to retreat."
Sleep 0.25
ishide = droll(1, 8)
If ishide > cave(pcl, foe) Then
Print
Print "The "; monster$(Abs(cave(pcl, foe))), " has scurried into the shadows."
Print
cave(pcl, foe) = -1 * cave(pcl, foe)
Else
score = score + Abs(cave(pcl, foe)) * 20
Print " "
Print "The ", monster$(Abs(cave(pcl, foe))), "has fled from this cave!"
Print
cave(pcl, foe) = 0
didhide = 0
go = 0
Do
go = go + 1
If cave(pcl, go) > 0 Then
cave(cave(pcl, go), foe) = cave(pcl, foe)
cave(pcl, foe) = 0
didhide = 1
End If
Loop Until didhide > 0
End If
End If
End If
End If
End Sub
Sub go_passage (gd As Integer, mode$)
walkflag$ = "no"
If cave(pcl, gd) = 0 Then
Print "You can't go that way."; ""
End If
If mode$ = "walk" Then
Print "walking"
If Abs(cave(pcl, foe)) > 0 Then
cave(pcl, foe) = Abs(cave(pcl, foe))
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "A "; monster$(cave(pcl, foe)); " blocks your way."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Else
walkflag$ = "yes"
End If
End If
If mode$ = "sneak" Then
Print "trying to sneak"
If Abs(cave(pcl, foe)) > 0 Then
cave(pcl, foe) = Abs(cave(pcl, foe))
If stealth + droll(2, 6) < (droll(4, 6) + cave(pcl, foe)) Then
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "A "; monster$(cave(pcl, foe)); " blocks your way."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Else
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "You slip past the "; monster$(cave(pcl, foe)); "."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print
walkflag$ = "yes"
End If
End If
End If
If mode$ = "run" Then
Print "trying to run"
If Abs(cave(pcl, foe)) > 0 And vigor > 0 Then
cave(pcl, foe) = Abs(cave(pcl, foe))
If vigor + droll(2, 6) < (droll(4, 6) + cave(pcl, foe)) And cave(pcl, foe) <> 5 Then
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "The "; monster$(cave(pcl, foe)); " blocks your way."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Else
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "You run past the "; monster$(cave(pcl, foe)); "."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print
walkflag$ = "yes"
End If
vigor = vigor - 1
End If
End If
If mode$ = "climb" Then
Print "trying to climb..."
If Abs(cave(pcl, foe)) > 0 And vigor > 0 Then
cave(pcl, foe) = Abs(cave(pcl, foe))
If vigor + droll(2, 6) < (droll(4, 6) + cave(pcl, foe)) And cave(pcl, foe) <> 5 Then
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "The "; monster$(cave(pcl, foe)); " blocks your way."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Else
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "You scramble past the "; monster$(cave(pcl, foe)); "."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print
If luck > droll(1, 12) Then
luck = luck - 1
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "You slip and hurt youself !."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
vigor = vigor - droll(1, 3)
Else
walkflag$ = "yes"
End If
End If
vigor = vigor - 1
End If
If mode$ = "jump" Then
If Abs(cave(pcl, foe)) > 0 And vigor > 0 Then
cave(pcl, foe) = Abs(cave(pcl, foe))
If vigor + droll(3, 6) < (droll(4, 6) + cave(pcl, foe)) Then
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "The "; monster$(cave(pcl, foe)); " blocks your way."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Else
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "You leap past the "; monster$(cave(pcl, foe)); "."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print
If luck > droll(1, 24) Then
luck = luck - 1
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
Print "You stumble and slam onto the rocky cave floor."
Print
Print "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
Print
vigor = vigor - droll(1, 3) + 1
Else
walkflag$ = "yes"
End If
End If
vigor = vigor - 1
End If
End If
End If
If walkflag$ = "yes" Then
Print
Print "-----------------------------------------------------------"
Print
Print "You travel onward to..."
Print " "
If cave(pcl, gd) = 99 Then heading_out
If gd <> 0 Then pcl = cave(pcl, gd)
Print cd$(cave(pcl, desc))
Print
Print "-----------------------------------------------------------"
End If
End Sub
Function truncate$ (a$)
b$ = "-"
If InStr(a$, "kill ") > 0 Then b$ = "hit"
If InStr(a$, "hit ") > 0 Then b$ = "hit"
If InStr(a$, "strike ") > 0 Then b$ = "hit"
If InStr(a$, "slay ") > 0 Then b$ = "hit"
If InStr(a$, "fight ") > 0 Then b$ = "hit"
If InStr(a$, "attack ") > 0 Then b$ = "hit"
If InStr(a$, "arrow") > 0 Then b$ = "shoot"
If InStr(a$, "fire ") > 0 Then b$ = "shoot"
If InStr(a$, "shoot ") > 0 Then b$ = "shoot"
If InStr(a$, "loose ") > 0 Then b$ = "shoot"
If InStr(a$, "blast") > 0 Then b$ = "castblast"
If InStr(a$, "heal") > 0 Then b$ = "castheal"
If InStr(a$, "rabbit") > 0 Then b$ = "castrabbit"
If InStr(a$, "oracle") > 0 Then b$ = "castoracle"
If b$ = "shoot" And InStr(a$, "north") Then b$ = "shootnorth"
If b$ = "shoot" And InStr(a$, "east") Then b$ = "shooteast"
If b$ = "shoot" And InStr(a$, "south") Then b$ = "shootsouth"
If b$ = "shoot" And InStr(a$, "west") Then b$ = "shootwest"
If b$ = "shoot" And InStr(a$, "up") Then b$ = "shootup"
If b$ = "shoot" And InStr(a$, "down") Then b$ = "shootdown"
If b$ = "-" Then
a$ = a$
Else
a$ = b$
End If
truncate$ = a$
End Function
Sub shootarrow (ad As Integer)
shootflag$ = "no"
If arrows > 0 Then shootflag$ = "arrow"
If Abs(cave(pcl, foe)) > 0 And shootflag$ = "arrow" Then
Select Case ad
Case 1, 2, 3, 4, 5, 6
Print " ! ! ! ! ! ! ! ! ! ! !"
Print
Print "You can't fire an arrow into another cave..."
Print " ... while this cave is occupied !"
Print "<enter>": Input a$
Case 0
shootflag$ = "yes"
End Select
End If
If shootflag$ = "arrow" And cave(pcl, ad) > 0 Then
Print " "
Print ">>>>----------------------------->"
Print
Print "You loose a magical arrow into the distance..."
Sleep 0.25
tr = cave(pcl, ad)
If cave(tr, foe) = 7 Then
arrows = arrows - 1
ad = droll(1, 12)
If ad <= luck Then
Print "... and hear the dragon roar in angush... "
Print " ... AS THE DRAGON DIES !!!"
Print
Print ">>>>----------------------------->"
Print
Print "<enter>": Input a$
cave(tr, foe) = 0
score = score + 1000
End If
Else
Print "... and hear it break against stone."
arrows = arrows - 1
Print " "
If droll(1, 20) > luck Then Print "You hear the dragon roar in the distance."
End If
End If
If shootflag$ = "arrow" And cave(pcl, ad) = 0 Then
Print " "
Print "You can't shoot in that direction."
Print
Print "<enter>": Input a$
End If
If shootflag$ = "yes" Then
Print
Print ">>>>----------------------------->"
Print
Print "You loose a magcial arrow..."
arrows = arrows - 1
Sleep 0.25
If droll(1, 6) > 1 And cave(pcl, foe) <> 7 Then
Print "slaying the "; monster$(Abs(cave(pcl, foe))); " !"
Print
cave(pcl, foe) = 0
score = score + cave(pcl, foe) * 100
End If
Print
If droll(1, 10) > 2 And cave(pcl, foe) = 7 Then
Print "Sinking it into the dragon's heart."
Print
Print "YOU HAVE KILLED THE DRAGON !!!"
Print
Print
cave(pcl, foe) = 0
score = score + 1000
End If
End If
Print "<enter>": Input a$
End Sub
Sub build_Player
maxvigor = droll(2, 6) + 6
maxluck = droll(4, 4)
maxperception = droll(3, 6)
maxstealth = droll(3, 6)
maxmagic = droll(3, 6)
vigor = maxvigor
luck = maxluck
perception = maxperception
stealth = maxstealth
magic = maxmagic
gold = 0
arrows = 3
End Sub
Sub show_scores
If havehearthstone = 1 Then
Print "+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+"
Print "You have the HearthStone"
Print "+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+"
End If
Print "Your Ability Scores."
Print
Print "Vigor", maxvigor; "/"; vigor
Print "Luck", luck
Print "Perception ", perception
Print "Stealth ", stealth
Print "Magic ", maxmagic; "/"; magic
Print
Print "Spells Known:";
If spellheal > 0 Then Print "Heal",
If spellblast > 0 Then Print "Blast",
If spelloracle > 0 Then Print "Oracle",
If spellrabbitfoot > 0 Then Print "Rabbit's Foot",
Print
Print "Gold ", gold
Print "Arrows ", arrows
Print
Print "Score ", score
End Sub
Sub cast_spell (cast$)
If cast$ = "heal" And spellheal > 0 Then
mcheck = magic - spellheal
Print " * * * * * * * * * * * * * * * * * * * *"
Print
If mcheck > magic Then
Print "You lack the magical power to cast that."
Else
Print "You magciall yheal some of your wounds."
magic = magic - droll(1, spellheal)
vigor = vigor + 4
If vigor > maxvigor Then vigor = maxvigor
End If
Print
Print " * * * * * * * * * * * * * * * * * * * *"
Print
Sleep 0.25
End If
If cast$ = "rabbit" And spellrabbitfoot > 0 Then
mcheck = magic - spellrabbitfoot
Print " * * * * * * * * * * * * * * * * * * * *"
Print
If mcheck > magic Then
Print "You lack the magical power to cast that."
luck = luck - 1
Else
Print "You improve your luck."
magic = magic - droll(1, spellrabbitfoot)
luck = luck + droll(1, 6)
'luck can go over maxluck with thius spell
End If
Print
Print " * * * * * * * * * * * * * * * * * * * *"
Print
Sleep 0.25
End If
If cast$ = "oracle" And spelloracle > 0 Then
mcheck = magic - spelloracle
Print " * * * * * * * * * * * * * * * * * * * *"
Print
If mcheck > oracle Then
Print "You lack the magical power to cast that."
perception = perception - (droll(1, 2) - 1)
Else
Print "You improve your perception."
magic = magic - droll(1, spelloracle)
perception = perception + 2
cave(pcl, foe) = Abs(cave(pcl, foe))
cave(pcl, loot) = Abs(cave(pcl, loot))
'the can go overmax perception
End If
Print
Print " * * * * * * * * * * * * * * * * * * * *"
Print
Sleep 0.25
End If
If cast$ = "blast" And spellblast > 0 Then
mcheck = magic - spellblast
Print " * * * * * * * * * * * * * * * * * * * *"
Print
If mcheck > magic Then
Print "You lack the magical power to cast that."
Else
Print "You blast your foe with magical energy."
magic = magic - droll(1, spellblast)
perception = perception - (droll(1, 3) - 1)
'this is a loud spell
If cave(pcl, foe) = 0 Then
Print "This would be much more effective against a foe you could see."
Else
If droll(1, 12) > cave(pcl, foe) Then
Print "Destroying the "; cave(pcl, foe); " !!!"
score = score + cave(pcl, foe) * 50
cave(pcl, foe) = 0
End If
End If
End If
Print
Print " * * * * * * * * * * * * * * * * * * * *"
Print
Sleep 0.25
End If
Select Case cast$
Case "castblast"
If spellblast < 1 Then Print "You have yet to learn that spell."
Case "castheal"
If spellheal < 1 Then Print "You are not a healer, yet."
Case "castrabbit"
If spellrabbitfoot < 1 Then Print "Do not tempt fate as you have yet to learn that spell."
luck = luck - 1
Case "castorcale"
If spellrabbitfoot < 1 Then Print "You have yet to discover an Oracle's Rune."
End Select
End Sub
Function droll (num, sides)
dsum = 0
For x = 1 To num
dsum = dsum + Int(Rnd * sides) + 1
Next x
droll = dsum
End Function
|
|
|
Basic for games only |
Posted by: Kernelpanic - 05-25-2022, 11:56 PM - Forum: General Discussion
- Replies (26)
|
|
I see again and again that Basic is apparently only used as a programming language for games etc., for example, but so Basic never gets rid of the "little-kids" level. Not that I want to deny games etc., but you can also develop serious programs with Basic, not just colorful circles and jumping who-knows-where.
So you can for example, write a program that calculates an additional payment to the pension.
An example: You take out an additional insurance into which you pay 3400.00 €/$ per year for 25 years. If you then go in pension, the program shows how much you can then have paid out from the supplementary insurance per month and for how many years. For me, this is a really practical program. There is certainly room for improvement, but this is something that can be used practically.
And in my very personal opinion, this is the only way to get Basic out of the gaming level and make it (again) a serious programming language.
That's my point of view.
|
|
|
Bouncing lines & boxes |
Posted by: Dav - 05-25-2022, 10:46 PM - Forum: Programs
- Replies (5)
|
|
Starting playing around with the power of LINE styles and it lead to 3d looking mystify like screensaver (in 1st code box). Afterwards changed it to bouncing boxes, added some fading. Kept in some LINE style stuff. (Code box #2). On my laptop 12 boxes seems to be the sweet spot when setting _LIMIT 30.
- Dav
Bouncing LINEs....
Code: (Select All) '=================
'BouncingLines.bas
'=================
'Coded by Dav, May/2022
SCREEN _NEWIMAGE(800, 600, 32)
RANDOMIZE TIMER
lines = 12 'Number of lines on screen
DIM line.x1(lines), line.y1(lines), line.cx1(lines), line.cy1(lines)
DIM line.x2(lines), line.y2(lines), line.cx2(lines), line.cy2(lines)
DIM line.r(lines), line.g(lines), line.b(lines), line.a(lines)
'Init values for each line
FOR s = 1 TO lines
line.y1(s) = INT(RND * _HEIGHT) + 1: line.x1(s) = INT(RND * _WIDTH) + 1
line.y2(s) = INT(RND * _HEIGHT) + 1: line.x2(s) = INT(RND * _WIDTH) + 1
line.cx1(s) = RND * 1: line.cy1(s) = RND * 1
line.cx2(s) = RND * 1: line.cy2(s) = RND * 1
line.r(s) = RND * 255: line.g(s) = RND * 255: line.b(s) = RND * 255
line.a(s) = RND * 75 + 15
NEXT
DO
FOR s = 1 TO lines
'draw line...
LINE (line.x1(s), line.y1(s))-(line.x2(s), line.y2(s)), _RGBA(line.r(s), line.g(s), line.b(s), line.a(s)), , 255
'shadow
LINE (line.x1(s) + 2, line.y1(s) + 2)-(line.x2(s) + 2, line.y2(s) + 2), _RGBA(0, 0, 0, line.a(s)), , 255
IF line.x1(s) <= 0 OR line.x1(s) >= _WIDTH THEN line.cx1(s) = -line.cx1(s)
IF line.y1(s) <= 0 OR line.y1(s) >= _HEIGHT THEN line.cy1(s) = -line.cy1(s)
IF line.x2(s) <= 0 OR line.x2(s) >= _WIDTH THEN line.cx2(s) = -line.cx2(s)
IF line.y2(s) <= 0 OR line.y2(s) >= _HEIGHT THEN line.cy2(s) = -line.cy2(s)
line.x1(s) = line.x1(s) + line.cx1(s): line.y1(s) = line.y1(s) + line.cy1(s)
line.x2(s) = line.x2(s) + line.cx2(s): line.y2(s) = line.y2(s) + line.cy2(s)
NEXT
_DISPLAY
_LIMIT 300
LOOP UNTIL INKEY$ <> ""
Bouncing faded boxes.....
Code: (Select All) '=================
'BouncingBoxes.bas
'=================
'Coded by Dav, May/2022
SCREEN _NEWIMAGE(800, 600, 32)
RANDOMIZE TIMER
boxes = 12 'Number of boxes on screen
DIM box.x1(boxes), box.y1(boxes), box.cx1(boxes), box.cy1(boxes)
DIM box.x2(boxes), box.y2(boxes), box.cx2(boxes), box.cy2(boxes)
DIM box.r(boxes), box.g(boxes), box.b(boxes), box.a(boxes)
'Init values for each box
FOR s = 1 TO boxes
box.y1(s) = INT(RND * _HEIGHT) + 1: box.x1(s) = INT(RND * _WIDTH) + 1
box.y2(s) = INT(RND * _HEIGHT) + 1: box.x2(s) = INT(RND * _WIDTH) + 1
box.cx1(s) = RND * 4: box.cy1(s) = RND * 4
box.cx2(s) = RND * 4: box.cy2(s) = RND * 4
box.r(s) = RND * 255: box.g(s) = RND * 255: box.b(s) = RND * 255
box.a(s) = RND * 75 + 15
NEXT
DO
CLS , _RGB(0, 0, 48)
FOR s = 1 TO boxes
'draw box
LINE (box.x1(s), box.y1(s))-(box.x2(s), box.y2(s)), _RGBA(box.r(s), box.g(s), box.b(s), box.a(s)), BF
'center lines
LINE (box.x1(s), box.y1(s))-(box.x2(s), box.y2(s)), _RGBA(255, 255, 255, box.a(s)), , 255
LINE (box.x2(s), box.y1(s))-(box.x1(s), box.y2(s)), _RGBA(255, 255, 255, box.a(s)), , 255
'box outline
LINE (box.x1(s), box.y1(s))-(box.x2(s), box.y2(s)), _RGBA(255, 255, 255, box.a(s)), B , 255
IF box.x1(s) <= 0 OR box.x1(s) >= _WIDTH THEN box.cx1(s) = -box.cx1(s)
IF box.y1(s) <= 0 OR box.y1(s) >= _HEIGHT THEN box.cy1(s) = -box.cy1(s)
IF box.x2(s) <= 0 OR box.x2(s) >= _WIDTH THEN box.cx2(s) = -box.cx2(s)
IF box.y2(s) <= 0 OR box.y2(s) >= _HEIGHT THEN box.cy2(s) = -box.cy2(s)
box.x1(s) = box.x1(s) + box.cx1(s): box.y1(s) = box.y1(s) + box.cy1(s)
box.x2(s) = box.x2(s) + box.cx2(s): box.y2(s) = box.y2(s) + box.cy2(s)
NEXT
_DISPLAY
_LIMIT 30
LOOP UNTIL INKEY$ <> ""
|
|
|
Pong Clone |
Posted by: SierraKen - 05-25-2022, 07:46 PM - Forum: Programs
- Replies (18)
|
|
With the help of B+'s reflection math code, I decided to make a Pong Clone today. You play against the computer using your mouse. First to reach 10 points wins. B+, I added your name to the welcome screen. Tell me what you think. It was a bit tricky to make it not too easy but also not impossible, I believe I found the right middle ground. There's a photo of it below. Thanks for the help B+, I've always wanted to make my own Pong. I know most of them have rectangle rackets but I found it's more enjoyable to aim the ball with a round racket instead.
Code: (Select All) 'Pong Clone by SierraKen - May 25, 2022.
'Thank you to B+ for the deflection math code!
_Title "Pong Clone - by SierraKen"
Screen _NewImage(800, 600, 32)
Cls
Locate 4, 35: Print "P O N G C L O N E"
Locate 7, 44: Print "By SierraKen"
Locate 10, 44: Print "With help by B+"
Locate 15, 25: Print "Use your mouse to control the round paddle on the right side."
Locate 16, 25: Print "First one to reach 10 points wins."
Locate 20, 37: Print "Press Mouse Button To Begin."
Do
While _MouseInput: Wend
If _MouseButton(1) = -1 Then GoTo begin:
Loop
begin:
Randomize Timer
' these remain constant
px = 350: py = 250: pr = 5: pc = _RGB32(0, 255, 0) ' <<<< lets label everything of puck with p
speed = 7 ' really keeping puck at constant speed
cx = 100: cy = 300: cr = 25: cc = _RGB32(255, 0, 0) 'Computer Racket
mx = 700: mr = 25: mc = _RGB32(255, 0, 0) ' <<<< evrything mouse starts with m , use different radius for mouse - Your Racket
score = 0
cscore = 0
start:
px = 400: py = 300
Cls
angle:
pa = _Pi(2) * Rnd ' pa = puck angle this is rnd times all directions 0 to 360 in degrees 0 to 2*pi in radians
ang = _R2D(pa)
If ang > 85 And ang < 95 Then GoTo angle:
If ang > 265 And ang < 275 Then GoTo angle:
Do
Cls ' Clear our work and recalulate and redraw everything
Line (25, 25)-(775, 25), _RGB32(255, 255, 255)
Line (25, 575)-(775, 575), _RGB32(255, 255, 255)
For nety = 25 To 575 Step 20
Line (400, nety)-(400, nety + 10), _RGB32(255, 255, 255)
Next nety
Locate 1, 10: Print " Computer: "; cscore
Locate 1, 78: Print " You: "; score
If cscore = 10 Then
_AutoDisplay
Cls
Locate 5, 40
Print "You Lose!"
Locate 10, 40
Print "Again (Y/N)?";
again:
ag$ = InKey$
If ag$ = "y" Or ag$ = "Y" Then GoTo begin:
If ag$ = "n" Or ag$ = "N" Or ag$ = Chr$(27) Then End
GoTo again
End If
If score = 10 Then
_AutoDisplay
Cls
Locate 5, 20
Print "You Win!"
Locate 10, 20
Print "Again (Y/N)?";
again2:
ag2$ = InKey$
If ag2$ = "y" Or ag2$ = "Y" Then GoTo begin:
If ag2$ = "n" Or ag2$ = "N" Or ag2$ = Chr$(27) Then End
GoTo again2
End If
a$ = InKey$
If a$ = " " Then GoTo start:
If a$ = Chr$(27) Then End
While _MouseInput: Wend ' better way to poll mouse and label mouse x, y as mx, my like everyone else
my = _MouseY
fillCircle mx, my, mr, mc ' draw mouse paddle
' check for collision
' first part measure distance between mouse center and puck center, is it less than radius of mouse + puck?
If Sqr((mx - px) ^ 2 + (my - py) ^ 2) < (pr + mr) Then ' (pr + pr2) to (r + rr) collision!
pa = _Atan2(py - my, px - mx) ' get the angle of the puck to the mouse
px = px + speed * Cos(pa) ' move the puck out of the mouse paddle
py = py + speed * Sin(pa) '
' show the collision and replacement of ball AFTER removed from inside the mouse
Line (mx, my)-(px, py), &HFFFFFFFF
_Display
_Delay .1
End If
If py > cy Then
cdist = py - cy
cy = cy + cdist / 6.25
End If
If py < cy Then
cdist = cy - py
cy = cy - cdist / 6.25
End If
fillCircle cx, cy, cr, cc
If Sqr((cx - px) ^ 2 + (cy - py) ^ 2) < (pr + cr) Then ' (pr + pr2) to (r + rr) collision!
pa = _Atan2(py - cy, px - cx) ' get the angle of the puck to the mouse
px = px + speed * Cos(pa) ' move the puck out of the mouse paddle
py = py + speed * Sin(pa) '
' show the collision and replacement of ball AFTER removed from inside the mouse
Line (cx, cy)-(px, py), &HFFFFFFFF
_Display
_Delay .1
End If
'keep puck out of wall = wall boundary +- radius of puck
If px > 775 Then cscore = cscore + 1: _Delay .25: GoTo start:
If px < 25 Then score = score + 1: _Delay .25: GoTo start:
If py > 575 - pr Then pa = -pa: py = 575 - pr ' move puck out of wall !!!
If py < 25 + pr Then pa = -pa: py = 25 + pr ' move puck out of wall !!!
' nove the puck along and draw it
px = px + speed * Cos(pa) ' now move the puck along it's new direction pa = puck angle
py = py + speed * Sin(pa) '
fillCircle px, py, pr, pc ' draw puck
_Display
_Limit 60 ' hold screen for moment
Loop
'from Steve Gold standard
Sub fillCircle (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
|
|
|
FABS - Qbasic |
Posted by: G43 - 05-25-2022, 01:47 PM - Forum: General Discussion
- Replies (25)
|
|
Has anyone ever heard of FABS Plus Net from Computer Control Systems. We use a program at my workplace that was written specially for a handful of automotive stores in the 80's and it calls FABSMB regularly. I have been researching and found a reference to FABS here http://www.gcssoft.de/ I am trying to debug a couple of things in the program and i need to find a copy of this FABS if it is possible to look at the index files that are in use. Any help would be appreciated.
Thanks,
Garrett
|
|
|
|