To avoid possible problems, I ask first. Is it possible to post here a very limited version of a very primirive virus written in QB64PE? I was interested in this topic, QB64 can do this. None virus source code will be inserted here without permision.
I chased this down this morning and think that this might be a bug. I am using v 3.6.0. From what I can tell you can omit the 'Call' command when calling a Sub and passing non-array variables, but when you call a Sub and pass an array you must have the 'Call' included. Omitting this when passing an array will generate a 'C++ compilation failed' error.
Here is sample code:
--------------------
Call test(b$())
Sub test (b$())
Print "HI"
End Sub
--------------------
The above compiles and works....but if the first line is any of the below iterations it will generate a 'C++ compilation failed' error - and it is not caught by the IDE:
test (b$())
test (b$)
It does not matter if you DIM or DIM SHARED for b$ either - you get the same results. Also it does not matter if the passed variable is a integer or string - you get the same results. I like to exclude 'Call' as I think the code looks cleaner without it, but in this case it just won't work. It appears that it is only an issue where an array is being passed to the Sub as the code below works fine:
--------------------
test (b$)
Sub test (b$)
Print "HI"
End Sub
--------------------
Also I wonder if the IDE needs help in this area too since the 'test (b$)' line in the FIRST example calls a Sub that requires an array, but the IDE does not catch that.
Thanks to all that dedicate work to this project !!!!
Dano
I tried passing *.* and *.? and similar as a string by Command$ into my program. But instead of the expected string with these three characters, I got a file listing in the form of a long string. I could also use this if...the individual file names were somehow separated. I did a parsing of the obtained string before posting this question here - everything is separated by plain space (CHR 32). This is completely unuseless for, because then you don't know if what you are reading is the continuation of the file name in which there is a space, or if it is the name of another file...
So - of course, from the start I was counting on direntry.h to give me the filenames, that works great - but - how to get the literal mask string *.* or ?????.* and so on? Having Command$ filter it out for me would only be useful if there were special ASC separators in the filenames it provides, like CHR$ 13 or ther characters (which can't be part of a filename)
qb64pe-json is a library for parsing and creating JSON strings. Currently it is hosted and developed on GitHub, and I just released the beta v0.1.0 version. Attached to this post is the v0.1.0 release, and also the examples currently present in the repository. Below is the README from the repository:
qb64pe-json
qb64pe-json is a JSON parsing and creation library for QB64-PE. Given a string containing JSON, it can convert it into a Json object which can then be queried to retrieve the values in the JSON. Additionally it contains a variety of
JsonTokenCreate*
functions which can be used to build up a Json object, which can then be rendered into a String version of that JSON.
Please see json.bi for more in-depth documentation around the API. Additionally see the examples/ for code samples of the API in use.
files into your project. Then reference the two files via
'$include:
.
Overall Design
qb64pe-json works by turning a JSON structure into a collection of "tokens", which are kept internal to a
Json
object. Tokens are allocated as needed, and token IDs are returned from several Functions. You can then pass a token ID into many of the APIs to interact with the token, such as get its value, get its children, etc. Valid token IDs are always positive.
The main Type in qb64pe-json is the
Json
Type. After declaring one, you need to pass it to
JsonInit
to initialize it, and eventually pass it to
JsonClear
to release it. Not passing a
Json
object to
JsonClear
will result in memory leaks.
There are four types of tokens - Objects, Arrays, Keys, and Values. Values are then split up into several "primitive" types a value can be, which are strings, numbers, bools, and
null
. A typical token structure looks something like this:
Object (1)
- Key (value = "key1") (2)
- Object (3)
- Key (value = "key2") (4)
- Value (type = number, value = 20) (5)
- Key (value = "key3") (6)
- Array (7)
- Value (type = bool, value = true) (8)
- Value (type = string, value = "string") (9)
- Value (type = null) (10)
- Key (value = "key4") (11)
- Value (type = number, value = 50) (12)
The numbers after each token signify its ID, which is what will be returned by the API when referring to that particular token. The typical way to interact with this structure is through
JsonQuery()
, which takes a query string and returns the token identified by it. For example, if you do
JsonQuery(json, "key1.key2")
, it will return 5, which is the token ID for the "20" Value token. You can then pass the token ID from that query to
JsonTokenGetValueInteger(token)
to retrieve the actual value 20 as an integer.
JsonQuery(json, "key2.key3")
returns 7, the token ID for the Array. With this array you can make use of
JsonTokenTotalChildren(array)
and pass it the token ID to retrieve the number of children (entries) in that array. You can then additionally make use of
JsonTokenGetChild(array, index)
to get the token ID of each child of the array. Note the indexes into the array start at zero, so
JsonTokenGetChild(array, 0)
would return 8, the bool in the array since it is the first entry.
JsonTokenGetChild(array, 2)
would return 10, the last entry in the array. You can of course then pass those token IDs to the various
JsonTokenGetValue
functions to retrieve their values.
If you have a token and need to know what it is, you can use
JsonTokenGetType(token)
to retrieve a
JSONTOK_TYPE_*
value indicating its type. If its type is
JSONTOK_TYPE_VALUE
, then you can additionally use
JsonTokenGetPrimType(token)
to get its primitive type, in the form of a
JSONTOK_PRIM_*
value.
Json
objects contain the concept of a "RootToken", which is simply the token of the base of the entire JSON structure. Several APIs start at the RootToken automatically, such as
JsonQuery()
,
JsonRender()
, etc. However all APIs offer an option to take a token directly to start with, ignoring the RootToken. This is powerful as it allows you to treat smaller subtrees of the entire structure as their own Json structure. For example in the above structure, you can use
JsonQueryFrom(3, "key2")
to do a query starting from the Object with index 3, completely ignoring the Object it's contained in.
Errors are reported from qb64pe-json via the global
JsonHadError
and
JsonError
variables.
JsonHadError
is zero (
JSON_ERR_Success
) when a function was successful, and a negative value when an error occurs. The negative values correspond to the
JSON_ERR_*
constants, and indicate the specific kind of error that occurred.
JsonError
will contain a human-readable string version of the error.
JSON Creation
In addition to parsing JSON, qb64pe-json allows you to create the Json structure yourself and then turn it into a JSON string (for storing or sending elsewhere). This is done by using the
JsonTokenCreate*()
functions. These functions create a new token and return its token ID. You can then make use of this token ID to add it to other tokens and build the Json structure. Objects and Arrays can have entries added to them via
JsonTokenArrayAdd
and
JsonTokenObjectAdd
.
Once you have built your Json structure, you can optionally use
JsonSetRootToken
to set the RootToken of the Json object to be the root of your created structure. Then, you can use
JsonRender$()
to produce a JSON string version of that structure.
JsonRenderFormatted$()
gives you more control over the rendering. Currently, it allows you to include indentation in the result, which makes it easier to read.
I'm just going to throw this into this place on the hope somebody out there could make use of it.
TL;DR It's a monophonic sequence creator for OpenMPT. It creates text-file patterns, each one to paste into the tracker.
It could use some improvements:
* do something about the hard-coded response file name and the output directory and filenames.
* be able to change the instrument command away from the first one.
* do something for those people who like wide open spaces in their piano music. The program as presented could fake arpeggiators very well.
* allow notes-off in the gaps.
* create polyphonic sequences, maybe the "main" one less accented than the other tracks.
* instead of accent, choose volume commands from a list. Optionally make them the same for the "piano roll".
* if working with samples, support some effect commands like pitch-bend, vibrato and retrigger. Yes I have done this and more but that program is way more complicated than this one. "Gotta have my edge...," Barry Bonds said once ROFLMAO.
An even better program would be to figure out Impulse Tracker module format, even with one "instrument" which is a looped sinewave, and create one of those things so you guys could play it back with a QB64(PE) program or with one of the players like VLC that supports music tracker modules. "MOD" looks easy but it's not, and the sound quality tends to be poor, and the format is restrictive because pretty much only two octaves are supported and the volume column cannot be used.
One easy way to check it out is to create the "omptchblende.txt" in the same directory as the executable:
* set the "omptchblende.txt" to the following:
Code: (Select All)
C-4;C-4;C-4;C-4;E-4;G#4
64
64
64
7
* This is only three different notes of the same octave, with "middle C" being chosen most often, and with most notes emphasized the strongest (like "ff" in sheet music, while others are like "mp" or "mf"). This will create one pattern which is 64 rows long. It will be called "pat01.txt" found in your Documents directory.
* download OpenMPT from https://openmpt.org
* if on Windows10 I recommend not downloading "legacy" version, unless you're full of VST plug-ins like I am LOL -- just choose either 32-bit or 64-bit option which is shown topmost on the download page.
* on Linux make sure you installed Wine and ran "winecfg", or for the users most experienced with doing this, set up a Wine "prefix". On some distros based on Arch Linux, if you opt for the 32-bit OpenMPT also install the 32-bit version of Portaudio: must have the repository data fully updated before doing on the terminal: "sudo pacman -S lib32-portaudio". If this is not done the WASAPI option won't be shown and the program will fail to produce any sound. This is unnecessary if you picked the 64-bit Windows application, again, the choice is whether or not you have to use VST2 plug-ins which come only in 32-bit or only in 64-bit. DO NOT CARE ABOUT THE "Wine" TAB OF THE PROGRAM PREFERENCES, it does not do what you might expect and you could mess up your installation!
* install it, or copy "portable" version anywhere you like in your user area, check sound card settings, shouldn't be many problems on Windows.
* WATCH OUT FOR YOUR HEARING LEVELS! Set the volume preferably to something near minimum. If you can't hear anything while using this program, SLOWLY raise the volume.
* Use File/New/MPTM. Could press the empty sheet icon on main toolbar but it creates an "IT" module which might not be convenient for this exercise. You might want to maximize the document window within app window.
* visit sample tab or press [ALT][S]. Choose the sun on the toolbar just above the empty waveform view. Accept whatever settings it says to create a waveform buffer. Then choose the pencil and just mouse-click and drag around to draw your own waveform!
* if you know a lot more than this you could import a looped multisample, or you could create an "OPL" instrument. But for "OPL" must be either "S3M" or "MPTM" format! Could also import from a SoundFont (SF2) but doesn't support layered patches. In other words if you loved that piano-string you heard in somebody's song and it's packed into a SoundFont, you could have either the piano or the string but not both. You'll have to load each component in their separate sample slots and play them together. If you know enough about "studio ways" the two multisamples could be mixed but that's less desireable sometimes. How about a combination that responds by music keyboard note (wood bass) and one that does not (ride cymbal), like that "jazz bass" patch I found in a Yamaha keyboard somewhere?
* press keyboard keys below the numbers, you should get the looped sample played and sustained at different pitches. Press [F8] or the square button on the transport to halt the sound.
* now change to pattern view or press [ALT][P].
* if you haven't done so already, load the pattern text file "pat01.txt" with Notepad or other good text editor, and copy the whole thing into the clipboard.
* switch to OpenMPT, focus on the first row of the first track with the mouse pointer, then paste.
* press play button on the transport or press [F5].
* if it sounds too "legato" for you LOL you could add notes-off to the gaps. Now I'm not sure what is the key for note-off, probably grave-accent because I have my own key map that I slowly modified for years using this program.
* alternatively with some notes try putting "SC1" on the right-hand-most column inside the track (channel). Type "S", then use right-arrow key, then type "C1" until it reads "SC1". After this is done the edit cursor should be at the right-hand edge of the track (channel). Play back and that note, and others modified this way, will sound off for a very short time! Might not even be heard. To do something about it, you will have to create an instrument related to that sample, but this is not a tutorial about composing music in a given tracker LOL.
* instead of the above to enter "SC1" could double-click near the pillar of the right-hand side of the channel, or press the "application" key between [ALT] and [CTRL] for the right hand. It should bring up a dialog. Under "Effects" (the bottom-most options) for the left-hand menu choose "SC", which is "note cut". Then use the related slider to choose a value of "1" from zero to 5. The "SC1" should appear on the pattern where you put the edit cursor.
* to change the tempo the effect letter is "T", and then a hexadecimal value which is from &H20 to &HFF. For 120BPM use "T78". Or visit the General tab.
Code: (Select All)
'by mnrvovrfc 16-Mar-2023, use for OpenMPT
'find the way to paste the patterns without getting bored!
$CONSOLE:ONLY
OPTION _EXPLICIT
DIM assn(1 TO 10) AS STRING
DIM assc(1 TO 10) AS INTEGER
DIM afile$, aline$, emptycell$, noat$, oldn$, ve$, sig$, closeit AS _BYTE
DIM AS INTEGER ss, seqlen, numlines, linespat, acch
DIM AS LONG ff, u, v, h, i, j
'initialize
afile$ = "omptchblende.txt"
IF NOT _FILEEXISTS(afile$) THEN
PRINT "File not found. This is needed to run the program."
SYSTEM
END IF
emptycell$ = "|" + STRING$(11, 46)
'the clipboard data must have the following as first line.
'the "MPT" means "MPTM" or "(Open) ModPlug Tracker Module" which is a "dirtied" version of Impulse Tracker module which has
' support for additional pattern commands and instrument microtuning.
'could instead be "IT" (Impulse Tracker), "XM" (FastTracker II), EITHER MUST HAVE AN ADDITIONAL SPACE AT FRONT
' or it could be "MOD" mostly for ancient Amiga Protracker 4-channel right-left-left-right format.
'however "IT" format cannot have "S9F", cannot have "#" parameter extension command and a few other things on pattern
' supported instead by "MPTM" format. Generally for new songs with VST plug-ins it's strongly recommended to do it in "MPTM" format.
' They tend to have better sound quality,
' while "IT" and "XM" are better for compatibility with players of those ancient formats, widely available.
'Scream Tracker "S3M" is sort of subset of "IT" which cannot have instruments, only samples and OPL synth assignments.
'"XM" actually supersedes "MOD" but there are so many "MOD" files around Internet which could be loaded by Commodore Amiga program.
'However, such things exist like 8-channel MOD created from a Windows program (don't remember what it was called).
'LOL sorry for the history, only wanted to demonstrate OpenMPT is friendly about pattern clipboard format.
sig$ = "ModPlug Tracker MPT"
seqlen = -1
numlines = -1
linespat = -1
acch = -1
'process the response file
ff = FREEFILE
OPEN afile$ FOR INPUT AS ff
DO UNTIL EOF(ff)
LINE INPUT #ff, aline$
IF aline$ <> "" THEN
u = INSTR(aline$, ";")
IF u > 0 THEN
ss = ss + 1
IF ss <= 10 THEN
assn(ss) = aline$
assc(ss) = CountString(aline$, ";")
END IF
ELSE
u = VAL(aline$)
IF u > 0 THEN
IF seqlen = -1 THEN
'what is the total length of the sequence we have to create?
seqlen = u
ELSEIF numlines = -1 THEN
'what is the length of the sequence (which could be repeated)?
numlines = u
ELSEIF linespat = -1 THEN
'how many rows per pattern?
linespat = u
ELSEIF acch = -1 THEN
'what is the chance (1 to 10) to accent notes?
acch = u
END IF
END IF
END IF
END IF
LOOP
CLOSE ff
'check the parameters for sanity
IF linespat < 16 OR linespat > 1024 THEN
PRINT "Preference processing error."
PRINT "linespat is not valid, must be from 16 to 1024."
SYSTEM
END IF
IF seqlen < linespat THEN
PRINT "Please change the value of seqlen in the preference file."
SYSTEM
END IF
IF acch < 1 OR acch > 10 THEN
PRINT "Preference processing error."
PRINT "acch must be from 1 to 10."
SYSTEM
END IF
RANDOMIZE TIMER
REDIM sq(1 TO seqlen) AS STRING
REDIM sf(1 TO numlines) AS STRING
'create the original sequence (like an ancient piano roll, it could be repeated)
oldn$ = ""
FOR j = 1 TO numlines
DO
v = Random1(10)
LOOP WHILE assc(v) = 0
h = assc(v)
DO
u = Random1(h)
noat$ = SSelect$(assn(v), u)
LOOP WHILE noat$ = ""
IF oldn$ = noat$ THEN
sf(j) = ""
ELSE
oldn$ = noat$
sf(j) = "|" + noat$ + "01"
END IF
NEXT
'now create the entire sequence, which will repeat but the accents will be in different places!
j = 1
FOR i = 1 TO seqlen
IF sf(j) = "" THEN
sq(i) = emptycell$
ELSE
sq(i) = sf(j)
IF Random1(10) > acch THEN ve$ = "..." ELSE ve$ = "v32"
IF j = numlines THEN
IF ve$ = "..." THEN ve$ = "==="
END IF
sq(i) = sq(i) + ve$ + "..."
END IF
j = j + 1
IF j > numlines THEN j = 1
NEXT
ERASE sf
'finally commit the patterns to disk
'later on LOL laboriously paste them into OpenMPT
'it was much easier on Windows using AutoHotKey...
v = 1
j = 1
$IF WIN THEN
afile$ = ENVIRON$("USERPROFILE") + "\Documents\pat" + Zeroes$(j, 3) + ".txt"
$ELSE
afile$ = ENVIRON$("HOME") + "/Documents/pat" + Zeroes$(j, 3) + ".txt"
$END IF
ff = FREEFILE
OPEN afile$ FOR OUTPUT AS ff
PRINT #ff, sig$
FOR i = 1 TO seqlen
PRINT #ff, sq(i)
v = v + 1
IF v > linespat THEN
PRINT afile$
v = 1
j = j + 1
$IF WIN THEN
afile$ = ENVIRON$("USERPROFILE") + "\Documents\pat" + Zeroes$(j, 3) + ".txt"
$ELSE
afile$ = ENVIRON$("HOME") + "/Documents/pat" + Zeroes$(j, 3) + ".txt"
$END IF
CLOSE ff
IF i = seqlen THEN
closeit = 0
ELSE
closeit = 1
ff = FREEFILE
OPEN afile$ FOR OUTPUT AS ff
PRINT #ff, sig$
END IF
END IF
NEXT
IF closeit THEN
PRINT afile$
CLOSE ff
END IF
PRINT j; "files written to disk. Completed."
SYSTEM
FUNCTION CountString% (tx$, delim$)
DIM AS LONG lx, z1, z2
DIM count AS INTEGER
IF (tx$ = "") OR (delim$ = "") THEN
CountString% = 0
EXIT FUNCTION
END IF
lx = LEN(delim$)
z1 = 1
z2 = INSTR(tx$, delim$)
count = 0
DO UNTIL z2 = 0
count = count + 1
z1 = z2 + lx
z2 = INSTR(z1, tx$, delim$)
LOOP
CountString% = count
END FUNCTION
'note: "delim$" could be a string of any size, preferably as short as possible
FUNCTION FieldString$ (tx$, ndx%, delim$)
DIM AS LONG lx, y, z1, z2
DIM count AS INTEGER
IF (tx$ = "") OR (delim$ = "") OR (ndx% < 1) THEN
FieldString$ = ""
ELSE
count = CountString(tx$, delim$) + 1
IF ndx% > count THEN
FieldString$ = ""
EXIT FUNCTION
END IF
lx = LEN(delim$)
z1 = 1
z2 = INSTR(tx$, delim$)
y = 0
DO UNTIL z2 = 0
y = y + 1
IF y >= ndx% THEN EXIT DO
z1 = z2 + lx
z2 = INSTR(z1, tx$, delim$)
LOOP
IF (z2 = 0) AND (y <= ndx%) THEN
FieldString$ = MID$(tx$, z1)
ELSE
FieldString$ = MID$(tx$, z1, z2 - z1)
END IF
END IF
END FUNCTION
FUNCTION LeftLen$ (tx$, numchar%)
IF tx$ = "" THEN
LeftLen$ = ""
ELSEIF numchar% > 0 THEN
LeftLen$ = LEFT$(tx$, LEN(tx$) - numchar%)
ELSE
LeftLen$ = tx$
END IF
END FUNCTION
FUNCTION Random1& (maxval AS LONG)
Random1 = INT(RND * maxval + 1)
END FUNCTION
FUNCTION SSelect$ (tx$, valu%)
SSelect$ = FieldString$(tx$, valu%, ";")
END FUNCTION
FUNCTION Zeroes$ (num AS LONG, numdig AS INTEGER)
DIM b$, sg AS _BYTE, hx AS _BYTE, v AS INTEGER
IF num < 0 THEN sg = -1: num = num * -1
IF numdig < 0 THEN hx = 1: numdig = numdig * -1 ELSE hx = 0
IF hx THEN
b$ = HEX$(num)
ELSE
b$ = LTRIM$(STR$(num))
END IF
v = numdig - LEN(b$)
IF v > 0 THEN b$ = STRING$(v, 48) + b$
IF sg = -1 THEN b$ = "-" + b$
Zeroes$ = b$
END FUNCTION
Is there ...i mean hear
any interest in windows include in form of awi32.bi
I figured if i want to continue with translation of my lexer from o2 to qb64pe
i need win api functions or should i just ignore it and made it more general purpose
that linux folks can use it too.
So, was digging through the wiki and here. Hoping for a command, or a library but is there a simple way to verify input as a filename that won't crash a program with an illegal character?
I had a tutorial user contact me about using the SHARED statement. He was trying to share variables in a subroutine like this:
SHARED a, b, c AS INTEGER
According to the Wiki this is not an alternate method of using SHARED, however, the IDE accepts this form and there is no run-time error either.
Code: (Select All)
DIM AS INTEGER a, b, c
a = 10
b = 20
c = 30
Mysub
SUB Mysub ()
'---------------
' ** Method 1 ** ------------> ** THIS WORKS **
'---------------
'SHARED AS INTEGER a, b, c ' all SHARED on a single line
'---------------
' ** Method 2 ** ------------> ** THIS WORKS **
'---------------
'SHARED a AS INTEGER ' all SHARED on a separate line
'SHARED b AS INTEGER
'SHARED c AS INTEGER
'---------------
' ** Method 3 ** ------------> ** THIS WORKS **
'---------------
'SHARED AS INTEGER a, b ' two different SHARED alternatives
'SHARED c AS INTEGER
'---------------
' ** Method 4 ** ------------> ** THIS DOES -NOT- WORK **
'---------------
'SHARED a, b, c AS INTEGER ' only the value of 'c' is passed, 'a' and 'b' are zero.
'-----------------------------------------------------------------------------------
' Method 4 is not a valid alternative to SHARED listed in the Wiki and should
' therefore not work. However, I would think an error would be generated in the IDE
' or at least at run-time when SHARED is attempted to be used in this manner?
'-----------------------------------------------------------------------------------
PRINT a, b, c
END SUB
Shouldn't method 4 above get flagged somehow as being incorrect?
This is Hex_Maze version 0B. It generates a crude labyrinth using hexes as cells as opposed to a standard orthogonal square grid.
There are a couple subs in it that don't get used in this run but would prove useful in using the hex-grid in a program.
Code: (Select All)
'hex_maze
'by James D. Jarvis Mar. 14,2023
' geneate a haex "maze" in a hex grid as opposed to a more standard orthogonal square grid
'generates a new hexmaze on a keypress press q to exit
Screen _NewImage(1100, 600, 32)
_FullScreen _SquarePixels , _Smooth
Randomize Timer
Dim Shared hexradius
Dim Shared hexborder As _Unsigned Long
hexborder = _RGB32(100, 100, 100)
hexradius = 8 'can be any value but draws cleaner if radius is evenly divisible by 4
maxx = 80: maxy = 40 'maxx is the maxximum number of columns and maxy is the maximum height of a column
Dim Shared map(maxx, maxy)
Dim Shared hgrid(0 To maxx + 1, 0 To maxy + 1, 6)
Do
Cls
For y = 1 To maxy
For x = 1 To maxx
map(x, y) = 1
Next x
Next y
sx = Int(maxx / 5 + Rnd * maxx / 2)
sy = Int(maxy / 5 + Rnd * maxy / 2)
'map(sx, sy) = 0
lastgo = Int(1 + Rnd * 6)
c = 0
clim = 600 + Int((1 + Rnd * 4) * (Rnd * (maxx + maxy))) 'determine how many hex cells will be dug for this hex maze haven't found an ideal ratio yet
hrun = 7
lasthrun = Int(1 + Rnd * 3)
Do
'generate hex maze with a drunken wanderer method. Not a true maze but it will work for a shoot-n-scoot or a roguelike
dgo = Int(1 + Rnd * 8) 'generate direction to send the tunnel
hrun = Int(1 + Rnd * (2 + Sqr(maxy))) 'generate a length for the tunnel being dug
If hrun > Sqr(maxy) Then hrun = lasthrun
If sx = 2 And dgo = 5 Then dgo = 3
If sx = 2 And dgo = 6 Then dgo = 2
If dgo > 6 Then dgo = lastgo
For hgo = 1 To hrun
Select Case dgo
Case 1
If sy - 1 > 1 Then
sy = sy - 1
End If
Case 2
If sx + 1 < maxx Then
If sx Mod 2 Then
If sy - 1 > 1 Then
sx = sx + 1
sy = sy - 1
End If
Else
sx = sx + 1
End If
End If
Case 3
If sx + 1 < maxx Then
If sx Mod 2 Then
sx = sx + 1
Else
If sy + 1 < (maxy - 1) Then
sx = sx + 1
sy = sy + 1
End If
End If
End If
Case 4
If sy + 1 < maxy Then
sy = sy + 1
End If
Case 5
If sx - 1 > 1 Then
If sx Mod 2 Then
If sy - 1 > 1 Then
sx = sx - 1
sy = sy - 1
End If
Else
sx = sx - 1
End If
End If
Case 6
If sx - 1 > 1 Then
If sx Mod 2 Then
sx = sx - 1
Else
If sy + 1 < (maxy - 1) Then
sx = sx - 1
sy = sy + 1
End If
End If
End If
End Select
If map(sx, sy) = 1 Then 'only dig out and count the hex-cell if it is filled
map(sx, sy) = 0
c = c + 1
End If
lastgo = dgo
lasthrun = hrun
Next hgo
Loop Until c >= clim
'draw the hex grid
For y = 1 To maxy
For x = 1 To maxx
If map(x, y) = 1 Then
hexat x, y
hexpaint x, y, _RGB32(200, 200, 200)
End If
Next x
Next y
_Display
Do
_KeyClear
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
Loop Until kk$ = "q"
Sub hexpaint (x, y, hklr As _Unsigned Long)
'paint an arbitrary hex
'hexradius and hexborder defined as shared variables in main program
hr = hexradius
If x Mod 2 Then
Paint ((x * 2) * hr * .75, y * (hr * 1.75)), hklr, hexborder
Else
Paint ((x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875)), hklr, hexborder
End If
End Sub
Sub hexput (sp&, x, y, sscale, hf)
'drop a sprite/image inside a hex , hf is hexfacing given in degrees
'sp& would be an image handle to a sprite created elsewere in program
hr = hexradius
If x Mod 2 Then
RotoZoom23d (x * 2) * hr * .75, y * (hr * 1.75), sp&, sscale, sscale, hf
Else
RotoZoom23d (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), sp&, sscale, sscale, hf
End If
End Sub
Sub hexat (xx, yy)
'draw an arbitrary hex, hexradius and hexborder are shared variables created in main porgram
hr = hexradius
y = yy
x = xx
If x Mod 2 Then
rotpoly (x * 2) * hr * .75, y * (hr * 1.75), hr, 60, 30, hexborder
Else
rotpoly (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), hr, 60, 30, hexborder
End If
End Sub
Sub hexgrid (xx, yy)
'draw a whole empty hexgrid
hr = hexradius
For y = 1 To yy
For x = 1 To xx
If x Mod 2 Then
rotpoly (x * 2) * hr * .75, y * (hr * 1.75), hr, 60, 30, hexborder
Else
rotpoly (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), hr, 60, 30, hexborder
End If
Next x
Next y
End Sub
Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
'draw an equilateral polygon (if shapedeg divides evenly into 360) centered on cx and cy
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
Line (cx + x, cy + y)-(cx + x, cy + y), klr
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
Line -(cx + x2, cy + y2), klr
Next
End Sub
'used in hexput to drop a sprite in a hex
Sub RotoZoom23d (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single)
Dim px(3) As Single: Dim py(3) As Single
Wi& = _Width(Image&): Hi& = _Height(Image&)
W& = Wi& / 2 * xScale
H& = Hi& / 2 * yScale
px(0) = -W&: py(0) = -H&: px(1) = -W&: py(1) = H&
px(2) = W&: py(2) = H&: px(3) = W&: py(3) = -H&
sinr! = Sin(-0.01745329 * Rotation): cosr! = Cos(-0.01745329 * Rotation)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, Hi& - 1)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(Wi& - 1, 0)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
None virus source code will be inserted here without permision. 
