Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 308
» Latest member: Donaldvem
» Forum threads: 1,741
» Forum posts: 17,901

Full Statistics

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.

Print this item

  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.

Print this item

Star 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'

Print this item

  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.

Print this item

  Question about the console mode
Posted by: Coolman - 05-26-2022, 04:59 PM - Forum: General Discussion - Replies (2)

hello, i made a console program ($Console:Only) that should run in a terminal. at the end of the execution i have the message :

Press enter to continue

how to avoid it.

Print this item

  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

Print this item

Question 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.

Print this item

  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$ <> ""

Print this item

  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. Smile 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. 

[Image: Pong-Clone-by-Sierra-Ken.jpg]

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

Print this item

  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

Print this item