Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.


Messages - The Librarian

Pages: [1] 2 3
1
Articles / MEM Blocks by Luke
« on: March 22, 2020, 01:40:10 pm »
MEM Blocks
Author: @luke
Last updated 2016-08-22


A _MEM block is a predefined UDT, with the following elements (all are read-only):

Code: [Select]
+-----------+---------+----------------------------------+
|Element    |Data type|Purpose                           |
+-----------+---------+----------------------------------+
|OFFSET     |_OFFSET  |Memory address of start of block. |
|SIZE       |_OFFSET  |Size of block in BYTES.           |
|TYPE       |LONG     |Bit-flags describing type of data.|
|ELEMENTSIZE|_OFFSET  |Size of datum in bytes.           |
|IMAGE      |LONG     |Image handle (if appropriate).    |
+-----------+---------+----------------------------------+

_MEM.OFFSET

A pointer to the beginning of the data in memory. Doing maths with this is always in bytes (_MEM.OFFSET + 1 is always the second byte in the block, regardless of the type of data). Can be passed to DECLARE LIBRARY routine if the routine's parameter is BYVAL p%& and the routine expects an int32_t (which is really more of a void*; cast it to the appropriate pointer type). C routines can then treat it as an array.

_MEM.SIZE

The size of the block in BYTES, not the number of data. Could possibly be 0. Note the data type is an _OFFSET not a LONG (or similar), so QB64 may have issues with how it is used (for instance, you can't assign it to a LONG).

_MEM.TYPE

Note:
  • Bits are numbered starting at 0, which is the least significant bit.
  • Exclusive means nothing else is set (except for Array. Array goes with anything).
Code: [Select]
+---+--------------------------------+---------------------------------------------------+
|Bit|Meaning w.r.t datum             |Combinability (if it be set along with other flags)|
+---+--------------------------------+---------------------------------------------------|
|0  |1 byte large.                   | |
|1  |2 bytes large.                  | |
|2  |4 bytes large.                  | |
|3  |8 bytes large.                  | |
|4  |16 bytes large (unused).        |                                                   |
|5  |32 bytes large.                 |Byte sizes are only set for simple numeric         |
|6  |64 bytes large (unused).        |types, including _OFFSET, and for pixel data. |
|7  |Integral type.                  | |
|8  |Floating-point type.            |7-9 set whenever appropriate, including pixel data.|
|9  |String type.                    |Exclusive. |
|10 |Unsigned type.                  |Goes with integral types and pixel data.           |
|11 |Pixel data from image.          |Sets byte size, integral and unsigned.             |
|12 |_MEM U.D.T                      |Exclusive.                                         |
|13 |_OFFSET data type.              |Goes with integral and byte sizes.                 |
|14 |Created by _MEMNEW or _MEM(x, y)|Exclusive.                                         |
|15 |U.D.T other than _MEM.          |Exclusive.                                         |
|16 |Array.                          |Other flags describe type of array element.        |
+---+--------------------------------+---------------------------------------------------+

_MEM.ELEMENTSIZE

The size of each datum in the block, in bytes. If the block was created with _MEMNEW or _MEM(x, y), this value is 1. If _MEM.TYPE has the Array flag set, this is the size of one array element.

_MEM.IMAGE

If the block was created by the _MEMIMAGE function, this is the handle of the image that was used. Otherwise, it is -1.


Command for creating and manipulating _MEM blocks.


General Notes

  • When a function requires 'block' and 'offset', 'offset' must be at least 'block.OFFSET', and at most 'block.OFFSET + block.SIZE - 1'. Of course, if the function accesses multiple bytes, the upper limit on 'offset' is decreased.
  • Some functions accept a parameter of type DTYPE. This is the literal word to refer to a data type, such as INTEGER or _UNSIGNED LONG.
  • When referring to an entire array (not just an element), empty parentheses must be used.
  • An array reference with a specific element "x(3)" is interpreted as a single variable, except for the one-argument form of the _MEM() function.
  • Multidimensional arrays are stored (0, 0), (1, 0), (2, 0) ... (9, 0), (0, 1), (1, 1), (2, 1) etc.
  • Elements in a UDT are simply stored one after the other.
_MEM

Code: QB64: [Select]
  1. block AS _MEM = _MEM(var AS ANY)
  2. block AS _MEM = _MEM(address AS _OFFSET, size AS _OFFSET)

In the first form, creates a new _MEM block referring the data in 'var', where 'var' is a numeric type, fixed-length string, UDT or array of such types. If an array is specified with an element e.g. "x(3)", the function takes this to mean an array beginning x(3) and all elements above that. It is vitally important to understand that the new _MEM block does not copy data from 'var'; the memory region is the same as 'var'. 'var' and the _MEM block are now two ways of accessing the same part of the computer's memory. This means that if 'var' is changed (by assignment, not with _MEM commands), the value in the _MEM block will change too. Similarly, using _MEMPUT to change the _MEM block will change the value of 'var'. As you may expect, if two _MEM regions 'm1' and 'm2' are both created with this function form from the same 'var', altering one will alter the other. If 'var' no longer exists (for instance, the SUB it existed in has finished), then the block is considered to have been freed, accessing the _MEM block is an error.

In the second form, creates a _MEM block to access memory beginning at 'address' in the computer's memory, and 'size' bytes long. Unlike _MEMNEW, which allocates a block of the size requested, _MEM() in the second form assumes that the memory at 'address' has already been allocated. This form is most useful when a function through DECLARE LIBRARY returns the address and size of a buffer it has stored information in; in this situation, the two data can be passed to _MEM() so that the _MEM commands can be used to access the data.

However, this second form gives great freedom, to the extent that it cannot always catch errors. If 'address' is incorrect, or 'size' is too large, it is possible to write to memory that the program is not allowed to access. This will generate a segmentation fault, which will either cause the program to crash immediately or trigger an OS-level error message (and then crash). If you're not using DECLARE LIBRARY, there's a good chance that you will never need this second 'unsafe' form of the _MEM function.

_MEMELEMENT

block AS _MEM = _MEMELEMENT(var AS ANY)

Like the one-argument form of the _MEM() function, creates a _MEM block which can be used to access 'var'. Unlike _MEM() though, if 'var' is an array with an element specified e.g. "x(3)", it is interpreted as a single variable only. Note that the Array flag of _MEM.TYPE is still set, even though the _MEM block only contains one datum. Other than that, _MEM.TYPE and _MEM.ELEMENTSIZE are set as one would expect for a single variable. Changing the data in the _MEM block will alter the element in the original array.

_MEMNEW

Code: QB64: [Select]
  1. block AS _MEM = _MEMNEW(size AS _OFFSET)

Returns a a _MEM block that refers to newly allocated memory where 'size' is its size in bytes, and may be 0. The contents of the block are unspecified; if a definite value is needed, _MEMFILL can be used to initalise the region. The allocation is not guaranteed; the underlying libaries and Operating System may fail to allocate the requested size. It is always prudent to verify that that it was successful by comparing 'block.SIZE' to 'size' - an inequality means failure. If it does fail, the program may try again with a smaller size, or give an error to the user then exit. Failed allocations must be freed with _MEMFREE. If 'size' is negative an Illegal Function Call is raised, but the returned block still needs to be freed. All _MEMNEW allocations have 'block.ELEMENTSIZE' set to 1.

[Author's note: I was able to successfully allocate a block up to the maximum size on my 32 bit machine (2^32/2 - 1) thanks to the magic of virtual memory, where the Operating System does not actually allocate physical RAM until it is used. I suspect I would not be able to actually assign data to all of it, given I only have 4 GiB of RAM installed.]

_MEMIMAGE

Code: QB64: [Select]
  1. block AS _MEM = _MEMIMAGE (handle AS LONG)
Note: the 'handle' argument is optional. If omitted, it defaults to the current write page (which by default is the one being displayed).

Returns a _MEM block that references the memory holding the image referred to by 'handle' (where 'handle' is a handle as returned by _NEWIMAGE and related functions). This can be seen a counterpart to the _MEM(x) function, in that the memory accessible IS the image; changes to the _MEM block affect the image itself. If the image is the active screen, changes are seen immediately (assuming _AUTODISPLAY). 'block.IMAGE' is set to 'handle'. If 'handle' does not refer to a valid image or refers to a hardware surface (image mode 33), Illegal Function Call is raised, and the returned _MEM block does not need to be freed. If the image is freed with _FREEIMAGE, the _MEM block is freed too.

For all graphical screen modes, the memory is a pixel-by-pixel representation of the screen. Each row of pixels on screen is placed one after the other, with the top row first. As an example, consider a 5x5 screen, with pixels labelled like so:

Code: [Select]
ABCDE
FGHIJ
KLMNO
PQRST
UVWXY

In memory, these pixels would be in alphabetical order. However, a pixel is not necessarily a byte. In 32 bit mode, each pixel is 4 bytes wide: one pixel per colour channel, in the order Blue, Green, Red, Alpha. Correspondingly, 'block.ELEMENTSIZE' is 4 for 32 bit mode. The programmer should be careful with the order of colour channel components, especially due to the reversing nature of little endian processors. To this end, the _RGBA32() function and the related colour functions should be used instead of working with raw numbers.

In text mode (SCREEN 0), we talk of character cells instead of pixels. Nevertheless, the translation for screen location to memory location is the same as it is for graphical pixels. This is in contrast to the usual column, row method of addressing text modes. Each character cell is two bytes (as recorded by 'block.ELEMENTSIZE'): the first cell is code-point of the character being displayed, the second stores the attribute information as set by COLOR. See the manual on the COLOR statement for more detail about the format of attribute information.

_MEMGET

_MEMGET block AS _MEM, offset AS _OFFSET, dest AS ANY
dest AS ANY = _MEMGET(block AS _MEM, offset AS _OFFSET, type AS DTYPE)

Accesses data in the _MEM block specified by 'block' at the address 'offset'. In the first form, the type of the data is inferred from the type of 'dest'. In the second form, the type is explicitly stated. Multibyte data types are considered to have their first byte at the location specified. On little endian machines at least, numeric types are read natively i.e. with the least significant byte first. This function is an excellent way to access the bit-by-bit representation of complex data types such as floating point numbers.

_MEMPUT

Code: QB64: [Select]
  1. _MEMPUT block AS _MEM, offset AS _OFFSET, src AS ANY
  2. _MEMPUT block AS _MEM, offset AS _OFFSET, src AS type AS DTYPE

Stores the data 'src' in the _MEM block specified by 'block' at the address 'offset'. Arrays, UDT's and strings (both variable and fixed length) are allowed. For numeric literals, it is necessary to use the second form to explicitly state the type of a variable, since it would be ambiguous otherwise (is "8" 1 byte wide, 2 bytes or 4 bytes, or maybe even a SINGLE?).

_MEMFILL

_MEMFILL block AS _MEM, offset AS _OFFSET, size AS _BYTE, src AS ANY
_MEMFILL block AS _MEM, offset AS _OFFSET, size AS _BYTE, src AS type AS DTYPE

Like _MEMPUT, stores the data 'src' in the _MEM block specified by 'block' at the address 'offset'. However, _MEMFILL then repeats this storage as many times as necessary to fill a region of memory 'size' bytes large. As for _MEMPUT, the second form is used when the type of a numeric literal needs to be explicitly stated. It is important to realise that since 'size' is a number of bytes, it is possible to specify a multibyte data type that does not fill the region exactly. For instance, a LONG (4 bytes) will fill a 10 byte region with 2 instances, plus 2 remaining bytes. In this case, _MEMFILL will use the first 2 bytes of the LONG to finish filling the region, despite this resulting in an incomplete representation of the data being stored in the last instance.

_MEMCOPY

Code: QB64: [Select]
  1. _MEMCOPY srcblock AS _MEM, srcoffset AS _OFFSET, size AS _OFFSET TO destblock AS _MEM, destoffset AS _OFFSET

Note: The "TO" is literal, and must be included in the statement.

Copies 'size' byte of data from 'srcoffset' in 'srcblock' to 'destoffset' in 'destblock'. 'srcblock' and 'destblock' may be the same. The source and destination regions are allowed to overlap each other; in this case, the copy will be done so as to do the Right Thing. _MEMCOPY makes a proper copy of the data. Unlike _MEM(x) and _MEMIMAGE, which simply create a reference to a location in memory, _MEMCOPY duplicates each byte. Altering the source at a later time will not alter the destination copy. 'size' may be zero (in which case no copy is performed) but may not be negative.

_MEMEXISTS

Code: QB64: [Select]
  1. bool AS LONG = _MEMEXISTS(block AS _MEM)

Returns -1 (true) or 0 (false) to indicate if 'block' is a valid _MEM block or not. A block is considered valid if it refers to a _MEM block, and has not been freed. See _MEMFREE for discussion of when a _MEM block is considered freed. Library routines in particular should be prudent about verifying a _MEM block's validity before accessing it.

_MEMFREE

Code: QB64: [Select]

Frees the memory region associated with 'block'. 'block' is now considered invalid, and any attempts to use it (other than creating a new block) are an error. If any other references to the memory exist, such as a variable when _MEM(x)/_MEMELEMENT() is used or an image when _MEMIMAGE is used, the memory may still be accessed through them without error. Attempting to free a _MEM block that has already been freed (or was never valid) is an error. Note that a _MEM block referring to a variable or image is considered freed if the variable or image no longer exists.

It is possible to leak memory if all references to a _MEM block created with _MEMNEW or _MEM(x, y) are lost (such as going out of scope when returning from a SUB) before they are feed. For this reason, the programmer should be careful to track all _MEM blocks and free when necessary. It is not necessary to free _MEM blocks immediately before a program exits.

$CHECKING

Code: QB64: [Select]

Enables and disables runtime safety checks, particularly for _MEM commands. As a meta-command, it has effect regardless of whether it is in some kind of conditional statement (since it is parsed at compile-time). $CHECKING:ON is the default, but turning it off will give a significant speed boost for code that uses _MEM commands. Checking can be turned off for only a section of code by surrounding it with $CHECKING:OFF ... $CHECKING:ON. When checking is off, what would have given a runtime error will now cause a segmentation fault, or simply overwrite parts of memory. Despite the dangers, once code is tested and working well it is well-worth turning off checking for small parts, especially inner loops.
******************************************************************************************

Data type equivalence table
Code: [Select]
+-----------+--------------------+---------+
|C type     |QB name |QB Symbol|
+-----------+--------------------+---------+
|N/A     |_UNSIGNED _BIT  |~`       |
|N/A     |_BIT |`        |
|N/A     |_BIT * n |`n       |
|N/A     |_UNSIGNED _BIT * n |~`n      |
|int8_t     |_BYTE |%%       |
|uint8_t    |_UNSIGNED _BYTE |~%%      |
|int16_t    |INTEGER    |%        |
|uint16_t   |_UNSIGNED INTEGER |~%       |
|int32_t    |LONG     |&        |
|uint32_t   |_UNSIGNED LONG |~&       |
|int64_t    |_INTEGER64 |&&       |
|uint64_t   |_UNSIGNED _INTEGER64|~&&      |
|float     |SINGLE    |!        |
|double     |DOUBLE |#        |
|long double|_FLOAT |##       |
|qbs*     |STRING |$        |
|qbs*       |STRING * n |$n       |
|ptrszint   |_OFFSET |%&       |
+-----------+--------------------+---------+







2
Articles / TCP/IP Communications by Luke
« on: March 22, 2020, 12:53:26 am »
TCP/IP Communications
Author: @luke


Conceptual overview

TCP is a protocol for communicating over a network. It guarantees that:
  • Data will arrive
  • It will arrive in order
  • It will arrive error-free
Obviously, if someone cuts the cable, nothing can be done.

A TCP connection is established between two parties, a client and server. When
started, the server will listen on a specific port. By listening on different
ports, multiple servers can be run on the same machine. When a client wishes to
connect, it requests a connection to the server, specifying its IP address (or a
text equivalent like www.google.com) and the port the server is on. The server
then accepts the connection request, and the connection is established.

Aside on ports: ports are numbers between 1 and 65535, and their use allows
multiple servers to run on the same machine. The client needs to know the port
the server is using beforehand - luckily, common services have standard ports:

HTTP (for internet pages): 80
SSH (secure remote access): 22
Telnet (insecure remote access): 23
SMTP (Send email): 25

On some systems, ports below 1024 may be protected, meaning a server can't
listen on them without administrator/superuser privliges.

TCP structures the data sent as a stream. This has many consequences:
  • Individual send operations do not mean data will arrive as separate chunks at the other end. You cannot tell where one chunk ends and the next starts.
  • But one send operation does not guarantee only one read operation will be needed. TCP may split the data, and it may arrive bit by bit, meaning more than one read operation is needed to collect it all.
Although this may sound limiting, the associated issues can be solved by either
sending a special signal to note the end of the data (NUL and Linefeed are popular
choices), or by first sending the size of the data as a pre-agreed numeric
data type, then sending the data itself.

TCP is full-duplex, meaning both parties can send and receive data. It is not
necessary to read all data before you can send any yourself.

_OPENCLIENT - Connect to a listening server

handle& = _OPENCLIENT("TCP/IP:1234:host")
Where 1234 can be any port number, and host can be any IPv4 address or any domain
name, upon which DNS resolution will be performed.

If you are connecting to a server, this is typically the first command used. It
establishes the connection, and returns a handle to refer to the connection by
later on. If handle& = 0, this indicates an error occurred connecting.

_OPENHOST - Begin listening on a specific port

server& = _OPENHOST("TCP/IP:1234")
Where 1234 can be any port number, but may be subject to Operating System
permission restrictions.

This is typically the first command a server will call, in the startup phase.
The program is then ready to accept connections to port 1234, by use of
_OPENCONNECTION.

Note: server& is a handle that refers to listening on a particular port, and does not
relate to any particular client. If server& = 0, an error occured.

_OPENCONNECTION - Accept incoming connection from a client

handle& = _OPENCONNECTION(server&)
Where server& is a handle returned by _OPENHOST.

Checks for any connection requests from clients, and accepts the next waiting
one, if any. If a new connection is established, handle& is non-zero, and is
a handle& used to refer to that particular connection. That is, each client
connection will have a different handle&.

If server& = 0 there are no clients attempting to connect, or establishing a
connection failed.

If clients attempt to connect faster than a server can accept their connections,
they will be queued. The size of the queue is limited by the Operating System -
if it is exceeded, clients will likely be refused a connection straight away.

In typical operation, a server will repeatedly call this function to check for
any new clients.

_CONNECTIONADDRESS$ - Get address information about a connection

info$ = _CONNECTIONADDRESS$(h&)
Where h& is a handle returned by any of _OPENCLIENT, _OPENHOST, _OPENCONNECTION.

In all three cases, the string returned as the format "TCP/IP:1234:address",
where 1234 is any port number and address is a IPv4 address or textual domain
name.

_OPENCLIENT handles: Returns the same string passed to _OPENCLIENT

_OPENHOST handles: Returns the listening port, and the public IP address of the
machine. _CONNECTIONADDRESS$ knows about NAT, so if a machine is behind a router
performing NAT, the address returned is the public address of the router, not
the local address of the machine.

_OPENCONNECTION handles: Returns the port from which the client is connecting,
and their IP address. In many cases, a client will be connecting from a randomly
assigned port number, usually towards the upper end of the range.

_CONNECTED - Check if a connection is still active

bool& = CONNECTED(h&)
Where h& is a handle returned by _OPENCLIENT, _OPENHOST, _OPENCONNECTION, and
bool& is a boolean value (-1 = true, 0 = false).

Returns the state of the connection, as far as the program can tell. _CONNECTED
will only notice a disconnection when a read or write (GET or PUT) operation
does not succeed due to the connection being closed or otherwise broken. Thus:
  • Simply calling _CONNECTED in a loop without any I/O is useless.
  • Even if the connection is closed, GET may still succeed if there is data in the incoming buffer. In this case, _CONNECTED will still return true.
Since GET and PUT do not raise any errors, or return a value indicating
success/failure, _CONNECTED can be called after them to get an idea of what
happened.

If h& has already been closed with CLOSE, an error is raised. A connection that
is found to be disconnected with _CONNECTED must still be closed with CLOSE.

Handles returned by _OPENHOST are always considered connected, since they are
not true connections.

CLOSE - Close a connection

CLOSE #h& 'The # is optional

Like with a file, this is how one shuts down a connection or listen. h& may be
a handle returned by _OPENCLIENT, _OPENHOST, _OPENCONNECTION. Depending on the
application, it may be useful to arrange for one end to send a 'acknowledge'
signal, to confirm the connection is ready to close.

Especially in longrunning server programs, closing used connections is important
for preventing memory leaks.

GET - Read data from a connection

GET #h&, , fixed_len
GET #h&, , text$
Where h& is a handle returned by _OPENCLIENT, _OPENCONNECTION (not _OPENHOST),
and fixed_len/text$ is the variable to hold the data.

Receives data from the connection, if any is present. The behaviour differs
depending on whether the receiving variable is fixed length (numbers, UDT's
including _MEM, arrays, fixed-length strings) or a variable length string.

If the data type is fixed, GET checks if there is sufficient data available to
fill it. If there is, the appropriate number of bytes are read from the stream,
and EOF(h) is set to 0. If insufficient (or no) data is available, no bytes are
read from the stream, and EOF(h) is set to -1. The value of the receiving
variable may or may not be changed, so don't count on either.

If the data type is a variable length string, GET will read all available bytes
from the stream and return them in the string. EOF(h) is always set to 0, even
if no bytes are read (an empty string is returned in that case). However, you
should be prepared to accept fragmented or joined-together data, due to the
nature of TCP.

In all cases, GET is non-blocking, meaning it does not wait for data to arrive.
(Some programming languages have blocking network functions, which will not
return until data arrives). Consequentially, the following code is common to
read a piece of data:

Code: QB64: [Select]
  1.   GET #h, , num&&

EOF(h) will return -1 (true) if the GET cannot retrieve a sufficient number of
bytes (in this case, 8) from the stream, and 0 (false) when it succeeds.

PUT - Send data on a connection

PUT #h&, , var
Where h& is a handle returned by _OPENCLIENT, _OPENCONNECTION (not _OPENHOST),
and var is the variable to send (a numeric type, string, array of fixed length
data, or UDT including _MEM).

The counterpart to GET, PUT sends data to the other party. Usage is straght
forward, although note that:
  • You cannot send an array of variable strings.
  • Sending a _MEM block sends the _MEM header itself, not the data it refers to.

3
Articles / Mouse Interface by Luke
« on: March 21, 2020, 11:54:35 pm »
An introductory text to the QB64 mouse interface
Author: @luke


High-level overview

Whenever a mouse event occurs, the mouse generates a message, and adds it to the end of a queue. Every message contains the entire state of the mouse: its location and the state of all buttons.

A mouse event is generated on any of the following events:
  • A button is pressed.
  • A button is released.
  • The mouse changes position.
Note that a message is *not* generated while a button is held down and the mouse is stationary. As long as you don't move the mouse, pressing and releasing a button will only generate two messages in total (one for press, one for release).

Dealing with the mouse queue

To fetch messages from the queue (so their data can be read), the _MOUSEINPUT command is used. It has the following behaviour: if a new message is available in the queue, fetch that one, make it the 'current' message, and return -1. If no messages are available, leave the 'current' message untouched, and return 0.

To actually read data, the commands _MOUSEX, _MOUSEY and _MOUSEBUTTON are used. These three commands query the data contained in the current message, as set by _MOUSEINPUT (described above). As long as _MOUSEINPUT is not called, these functions will always be accessing the same message, and thus always return the same data.

By default, the current message is undefined, and calling the data-access functions without first loading a message with _MOUSEINPUT is pointless.

Commands to fetch data

_MOUSEX, _MOUSEY: Returns the X & Y coordinates of the mouse described in the current message. In graphics modes, it is an integer value, equivalent to the pixel coordinate system used by graphics commands (i.e., PSET (_MOUSEX, _MOUSEY) will plot a point directly where the mouse is). For text mode, _MOUSEX & _MOUSEY will return a floating-point value. The coordinate are in character units but with the origin such that (1, 1) is the *middle* of the character located in the top-left corner. That is, (0.5, 0.5) is the top-left of the screen. Because the character cells are not square, 1 unit in the Y direction is a larger distance onscreen than 1 unit in the X direction.

_MOUSEBUTTON(n): Returns the state of button number n; -1 if the button is pressed, 0 if it is not. Programs can rely on the following button numbers:
  • 1 = left mouse button
  • 2 = right mouse button
  • 3 = middle mouse button
No other buttons are currently defined. On Windows, if the user has chosen to swap left and right mouse buttons, this setting will not be respected. Accessing this information in the registry is detailed below.

_MOUSEHWEEL: Returns the amount of scroll on the scroll wheel. Unlike other functions that simply inspect the current mouse message, _MOUSEHWEEL keeps a running tally of mouse wheel activity, examing every mouse message as it comes to the front of the queue automatically. Whenever _MOUSEHWEEL sees the wheel scrolled towards the user, it adds 1 to its internal count. When it is scrolled away, it subtracts 1. When _MOUSEWHEEL is read, its value is reset to 0. Thus, _MOUSEWHEEL's return value reflects the net amount of scroll since _MOUSEWHEEL was last called.

***************************************************
* Note: the scroll wheel does not function on OSX *
***************************************************

Code analysis

(We use a _LIMIT 30 in our main loops here. This is solely to show where a _LIMIT should be placed; no precise value is being recommended)

Code: QB64: [Select]
  1. DO 'main program loop
  2.         'Do stuff with mouse
  3.     END IF
  4.     'do other stuff
  5.     _LIMIT 30

A naive implementation. Although this may suffice for trivial programs, as the "do stuff with mouse" increases in complexity, executing it with every mouse message quickly brings the main loop under its _LIMIT value. Remember, a mouse message is generated every time the mouse changes position, so a simple drag from one side of the window to the other will generate hundreds of messages.

Code: QB64: [Select]
  1. DO 'main program loop
  2.     'Access mouse data
  3.     'Do other stuff
  4.     _LIMIT 30

A solid improvement. The inner loop will continually fetch new messages from the queue until it is empty, leaving the last message as the current one. We then accesses data from that last message. Since the queue is a first-in first-out structure, this effectively loads the most recent mouse state. Although this avoids the message overload seen in the first method, it is entirely possible to miss mouse clicks.

Code: QB64: [Select]
  1.         IF _MOUSEBUTTON(1) = mouse_down THEN 'Is the button still in the same position?
  2.             DO WHILE _MOUSEINPUT
  3.                 IF _MOUSEBUTTON(1) <> mouse_down THEN EXIT DO 'Process through the queue until the button changes state
  4.             LOOP
  5.         END IF
  6.         mouse_down = _MOUSEBUTTON(1)
  7.         'Do mouse processing here
  8.     END IF
  9.     'Do other stuff
  10.     _LIMIT 30

A more advanced method. Like above, we repeatedly call _MOUSEINPUT to skip over the many messages generated by movement. In addition, we stop going along the queue if the mouse button's state changes. Thus it is impossible to miss a mouse click, no matter how long the main loop takes. The author has used this technique with great success in a menu & button GUI library to detect mouse clicks.

Windows registry

On Windows, reversing the mouse buttons is not done by modifiying input to programs, but rather by setting a registry key and expecting programs to respect it. The following code, based on a demo by Michael Calkins, has proven useful:

Code: QB64: [Select]
  1. $IF WINDOWS THEN
  2.     'This code largely based on a demo by Michael Calkins
  3.     DECLARE DYNAMIC LIBRARY "advapi32"
  4.         FUNCTION RegOpenKeyExA& (BYVAL hKey AS _OFFSET, lpSubKey$, BYVAL ulOptions AS _UNSIGNED LONG, BYVAL samDesired AS _UNSIGNED LONG, BYVAL phkResult AS _OFFSET)
  5.         FUNCTION RegCloseKey& (BYVAL hKey AS _OFFSET)
  6.         FUNCTION RegQueryValueExA& (BYVAL hKey AS _OFFSET, lpValueName$, BYVAL lpReserved AS _OFFSET, BYVAL lpType AS _OFFSET, lpData$, BYVAL lpcbData AS _OFFSET)
  7.     END DECLARE
  8.     result$ = SPACE$(2)
  9.     rsize = 2
  10.     l1 = RegOpenKeyExA(&H80000001, "Control Panel\Mouse" + CHR$(0), 0, &H20019, _OFFSET(hkey%&))
  11.     l2 = RegQueryValueExA(hkey%&, "SwapMouseButtons" + CHR$(0), 0, 0, result$, _OFFSET(rsize))
  12.     l3 = RegCloseKey(hkey%&)
  13.     IF l1 = 0 AND l2 = 0 AND left$(result$, 1) = "1" THEN
  14.         Swapmouse = -1
  15.     END IF

The variable Swapmouse will then be -1 is the mouse buttons should be swapped, 0 otherwise. Note that on non-Windows (on Linux, at least. The author does not know the behaviour on OSX.) platforms, the program receives the buttons already swapped to the user's desire, so there is never any need to swap within the program.

4
Interpreters / Math Evaluator by SMcNeill
« on: March 21, 2020, 11:28:52 pm »
Math Evaluator

Author: @SMcNeill
Source: QB64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1555.0
Version: Jan 07, 2020
Tags: [qb64], [interpreter]

Description:
Here's my little math evaluation routine, which everybody's been using for ages, even if they don't know they have!  :D

If you look inside QB64.bas, you'll see these routines, which are what the IDE uses to calculate math values for use with CONST and then substitute the finished product into your code.


Source Code:
Code: QB64: [Select]
  1. SCREEN _NEWIMAGE(1024, 720, 32)
  2. REDIM SHARED OName(0) AS STRING 'Operation Name
  3. REDIM SHARED PL(0) AS INTEGER 'Priority Level
  4. REDIM SHARED PP_TypeMod(0) AS STRING, PP_ConvertedMod(0) AS STRING 'Prepass Name Conversion variables.
  5.  
  6.     i$ = INPUT$(1)
  7.     CLS
  8.  
  9.     PRINT "Formula to Evaluate => ";
  10.     SELECT CASE i$
  11.         CASE CHR$(8)
  12.             eval$ = LEFT$(eval$, LEN(eval$) - 1)
  13.         CASE CHR$(13)
  14.             eval$ = ""
  15.         CASE CHR$(27)
  16.             SYSTEM
  17.         CASE ELSE
  18.             eval$ = eval$ + i$
  19.     END SELECT
  20.     PRINT eval$
  21.     result$ = Evaluate_Expression(eval$)
  22.     PRINT "Result: "; result$
  23.     _CLIPBOARD$ = eval$ + " = " + result$
  24.  
  25.  
  26. 'Steve Subs/Functins for _MATH support with CONST
  27. FUNCTION Evaluate_Expression$ (e$)
  28.     t$ = e$ 'So we preserve our original data, we parse a temp copy of it
  29.     PreParse t$
  30.  
  31.  
  32.     IF LEFT$(t$, 5) = "ERROR" THEN Evaluate_Expression$ = t$: EXIT FUNCTION
  33.  
  34.     'Deal with brackets first
  35.     EXP$ = "(" + t$ + ")" 'Starting and finishing brackets for our parse routine.
  36.  
  37.     DO
  38.         Eval_E = INSTR(EXP$, ")")
  39.         IF Eval_E > 0 THEN
  40.             c = 0
  41.             DO UNTIL Eval_E - c <= 0
  42.                 c = c + 1
  43.                 IF Eval_E THEN
  44.                     IF MID$(EXP$, Eval_E - c, 1) = "(" THEN EXIT DO
  45.                 END IF
  46.             LOOP
  47.             s = Eval_E - c + 1
  48.             IF s < 1 THEN Evaluate_Expression$ = "ERROR -- BAD () Count": EXIT SUB
  49.             eval$ = " " + MID$(EXP$, s, Eval_E - s) + " " 'pad with a space before and after so the parser can pick up the values properly.
  50.  
  51.             'PRINT "Before ParseExpression: "; eval$
  52.             ParseExpression eval$
  53.             'PRINT "After ParseExpression: "; eval$
  54.             eval$ = LTRIM$(RTRIM$(eval$))
  55.             IF LEFT$(eval$, 5) = "ERROR" THEN Evaluate_Expression$ = eval$: EXIT SUB
  56.             EXP$ = DWD(LEFT$(EXP$, s - 2) + eval$ + MID$(EXP$, Eval_E + 1))
  57.             'PRINT exp$
  58.             IF MID$(EXP$, 1, 1) = "N" THEN MID$(EXP$, 1) = "-"
  59.  
  60.             'temppp$ = DWD(LEFT$(exp$, s - 2) + " ## " + eval$ + " ## " + MID$(exp$, e + 1))
  61.         END IF
  62.     LOOP UNTIL Eval_E = 0
  63.     c = 0
  64.     DO
  65.         c = c + 1
  66.         SELECT CASE MID$(EXP$, c, 1)
  67.             CASE "0" TO "9", ".", "-" 'At this point, we should only have number values left.
  68.             CASE ELSE: Evaluate_Expression$ = "ERROR - Unknown Diagnosis: (" + EXP$ + ") ": EXIT SUB
  69.         END SELECT
  70.     LOOP UNTIL c >= LEN(EXP$)
  71.  
  72.     Evaluate_Expression$ = EXP$
  73.  
  74.  
  75.  
  76. SUB ParseExpression (EXP$)
  77.     DIM num(10) AS STRING
  78.     'PRINT exp$
  79.     EXP$ = DWD(EXP$)
  80.     'We should now have an expression with no () to deal with
  81.     'IF MID$(exp$, 2, 1) = "-" THEN exp$ = "0+" + MID$(exp$, 2)
  82.     FOR J = 1 TO 250
  83.         lowest = 0
  84.         DO UNTIL lowest = LEN(EXP$)
  85.             lowest = LEN(EXP$): OpOn = 0
  86.             FOR P = 1 TO UBOUND(OName)
  87.                 'Look for first valid operator
  88.                 IF J = PL(P) THEN 'Priority levels match
  89.                     IF LEFT$(EXP$, 1) = "-" THEN op = INSTR(2, EXP$, OName(P)) ELSE op = INSTR(EXP$, OName(P))
  90.                     IF op > 0 AND op < lowest THEN lowest = op: OpOn = P
  91.                 END IF
  92.             NEXT
  93.             IF OpOn = 0 THEN EXIT DO 'We haven't gotten to the proper PL for this OP to be processed yet.
  94.             IF LEFT$(EXP$, 1) = "-" THEN op = INSTR(2, EXP$, OName(OpOn)) ELSE op = INSTR(EXP$, OName(OpOn))
  95.             numset = 0
  96.  
  97.             '*** SPECIAL OPERATION RULESETS
  98.             IF OName(OpOn) = "-" THEN 'check for BOOLEAN operators before the -
  99.                 SELECT CASE MID$(EXP$, op - 3, 3)
  100.                     CASE "NOT", "XOR", "AND", "EQV", "IMP"
  101.                         EXIT DO 'Not an operator, it's a negative
  102.                 END SELECT
  103.                 IF MID$(EXP$, op - 3, 2) = "OR" THEN EXIT DO 'Not an operator, it's a negative
  104.             END IF
  105.  
  106.             IF op THEN
  107.                 c = LEN(OName(OpOn)) - 1
  108.                 DO
  109.                     SELECT CASE MID$(EXP$, op + c + 1, 1)
  110.                         CASE "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ".", "N": numset = -1 'Valid digit
  111.                         CASE "-" 'We need to check if it's a minus or a negative
  112.                             IF OName(OpOn) = "_PI" OR numset THEN EXIT DO
  113.                         CASE ",": numset = 0
  114.                         CASE ELSE 'Not a valid digit, we found our separator
  115.                             EXIT DO
  116.                     END SELECT
  117.                     c = c + 1
  118.                 LOOP UNTIL op + c >= LEN(EXP$)
  119.                 e = op + c
  120.  
  121.                 c = 0
  122.                 DO
  123.                     c = c + 1
  124.                     SELECT CASE MID$(EXP$, op - c, 1)
  125.                         CASE "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ".", "N" 'Valid digit
  126.                         CASE "-" 'We need to check if it's a minus or a negative
  127.                             c1 = c
  128.                             bad = 0
  129.                             DO
  130.                                 c1 = c1 + 1
  131.                                 SELECT CASE MID$(EXP$, op - c1, 1)
  132.                                     CASE "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "."
  133.                                         bad = -1
  134.                                         EXIT DO 'It's a minus sign
  135.                                     CASE ELSE
  136.                                         'It's a negative sign and needs to count as part of our numbers
  137.                                 END SELECT
  138.                             LOOP UNTIL op - c1 <= 0
  139.                             IF bad THEN EXIT DO 'We found our seperator
  140.                         CASE ELSE 'Not a valid digit, we found our separator
  141.                             EXIT DO
  142.                     END SELECT
  143.                 LOOP UNTIL op - c <= 0
  144.                 s = op - c
  145.                 num(1) = MID$(EXP$, s + 1, op - s - 1) 'Get our first number
  146.                 num(2) = MID$(EXP$, op + LEN(OName(OpOn)), e - op - LEN(OName(OpOn)) + 1) 'Get our second number
  147.                 IF MID$(num(1), 1, 1) = "N" THEN MID$(num(1), 1) = "-"
  148.                 IF MID$(num(2), 1, 1) = "N" THEN MID$(num(2), 1) = "-"
  149.                 IF num(1) = "-" THEN
  150.                     num(3) = "N" + EvaluateNumbers(OpOn, num())
  151.                 ELSE
  152.                     num(3) = EvaluateNumbers(OpOn, num())
  153.                 END IF
  154.                 IF MID$(num(3), 1, 1) = "-" THEN MID$(num(3), 1) = "N"
  155.                 'PRINT "*************"
  156.                 'PRINT num(1), OName(OpOn), num(2), num(3), exp$
  157.                 IF LEFT$(num(3), 5) = "ERROR" THEN EXP$ = num(3): EXIT SUB
  158.                 EXP$ = LTRIM$(N2S(DWD(LEFT$(EXP$, s) + RTRIM$(LTRIM$(num(3))) + MID$(EXP$, e + 1))))
  159.                 'PRINT exp$
  160.             END IF
  161.             op = 0
  162.         LOOP
  163.     NEXT
  164.  
  165.  
  166.  
  167.  
  168. SUB Set_OrderOfOperations
  169.     'PL sets our priortity level. 1 is highest to 65535 for the lowest.
  170.     'I used a range here so I could add in new priority levels as needed.
  171.     'OName ended up becoming the name of our commands, as I modified things.... Go figure!  LOL!
  172.     REDIM OName(10000) AS STRING, PL(10000) AS INTEGER
  173.     'Constants get evaluated first, with a Priority Level of 1
  174.  
  175.     i = i + 1: OName(i) = "C_UOF": PL(i) = 5 'convert to unsigned offset
  176.     i = i + 1: OName(i) = "C_OF": PL(i) = 5 'convert to offset
  177.     i = i + 1: OName(i) = "C_UBY": PL(i) = 5 'convert to unsigned byte
  178.     i = i + 1: OName(i) = "C_BY": PL(i) = 5 'convert to byte
  179.     i = i + 1: OName(i) = "C_UIN": PL(i) = 5 'convert to unsigned integer
  180.     i = i + 1: OName(i) = "C_IN": PL(i) = 5 'convert to integer
  181.     i = i + 1: OName(i) = "C_UIF": PL(i) = 5 'convert to unsigned int64
  182.     i = i + 1: OName(i) = "C_IF": PL(i) = 5 'convert to int64
  183.     i = i + 1: OName(i) = "C_ULO": PL(i) = 5 'convert to unsigned long
  184.     i = i + 1: OName(i) = "C_LO": PL(i) = 5 'convert to long
  185.     i = i + 1: OName(i) = "C_SI": PL(i) = 5 'convert to single
  186.     i = i + 1: OName(i) = "C_FL": PL(i) = 5 'convert to float
  187.     i = i + 1: OName(i) = "C_DO": PL(i) = 5 'convert to double
  188.     i = i + 1: OName(i) = "C_UBI": PL(i) = 5 'convert to unsigned bit
  189.     i = i + 1: OName(i) = "C_BI": PL(i) = 5 'convert to bit
  190.  
  191.     'Then Functions with PL 10
  192.     i = i + 1:: OName(i) = "_PI": PL(i) = 10
  193.     i = i + 1: OName(i) = "_ACOS": PL(i) = 10
  194.     i = i + 1: OName(i) = "_ASIN": PL(i) = 10
  195.     i = i + 1: OName(i) = "_ARCSEC": PL(i) = 10
  196.     i = i + 1: OName(i) = "_ARCCSC": PL(i) = 10
  197.     i = i + 1: OName(i) = "_ARCCOT": PL(i) = 10
  198.     i = i + 1: OName(i) = "_SECH": PL(i) = 10
  199.     i = i + 1: OName(i) = "_CSCH": PL(i) = 10
  200.     i = i + 1: OName(i) = "_COTH": PL(i) = 10
  201.     i = i + 1: OName(i) = "COS": PL(i) = 10
  202.     i = i + 1: OName(i) = "SIN": PL(i) = 10
  203.     i = i + 1: OName(i) = "TAN": PL(i) = 10
  204.     i = i + 1: OName(i) = "LOG": PL(i) = 10
  205.     i = i + 1: OName(i) = "EXP": PL(i) = 10
  206.     i = i + 1: OName(i) = "ATN": PL(i) = 10
  207.     i = i + 1: OName(i) = "_D2R": PL(i) = 10
  208.     i = i + 1: OName(i) = "_D2G": PL(i) = 10
  209.     i = i + 1: OName(i) = "_R2D": PL(i) = 10
  210.     i = i + 1: OName(i) = "_R2G": PL(i) = 10
  211.     i = i + 1: OName(i) = "_G2D": PL(i) = 10
  212.     i = i + 1: OName(i) = "_G2R": PL(i) = 10
  213.     i = i + 1: OName(i) = "ABS": PL(i) = 10
  214.     i = i + 1: OName(i) = "SGN": PL(i) = 10
  215.     i = i + 1: OName(i) = "INT": PL(i) = 10
  216.     i = i + 1: OName(i) = "_ROUND": PL(i) = 10
  217.     i = i + 1: OName(i) = "_CEIL": PL(i) = 10
  218.     i = i + 1: OName(i) = "FIX": PL(i) = 10
  219.     i = i + 1: OName(i) = "_SEC": PL(i) = 10
  220.     i = i + 1: OName(i) = "_CSC": PL(i) = 10
  221.     i = i + 1: OName(i) = "_COT": PL(i) = 10
  222.     i = i + 1: OName(i) = "ASC": PL(i) = 10
  223.     i = i + 1: OName(i) = "CHR$": PL(i) = 10
  224.     i = i + 1: OName(i) = "C_RG": PL(i) = 10 '_RGB32 converted
  225.     i = i + 1: OName(i) = "C_RA": PL(i) = 10 '_RGBA32 converted
  226.     i = i + 1: OName(i) = "_RGB": PL(i) = 10
  227.     i = i + 1: OName(i) = "_RGBA": PL(i) = 10
  228.     i = i + 1: OName(i) = "C_RX": PL(i) = 10 '_RED32 converted
  229.     i = i + 1: OName(i) = "C_GR": PL(i) = 10 ' _GREEN32 converted
  230.     i = i + 1: OName(i) = "C_BL": PL(i) = 10 '_BLUE32 converted
  231.     i = i + 1: OName(i) = "C_AL": PL(i) = 10 '_ALPHA32 converted
  232.     i = i + 1: OName(i) = "_RED": PL(i) = 10
  233.     i = i + 1: OName(i) = "_GREEN": PL(i) = 10
  234.     i = i + 1: OName(i) = "_BLUE": PL(i) = 10
  235.     i = i + 1: OName(i) = "_ALPHA": PL(i) = 10
  236.  
  237.     'Exponents with PL 20
  238.     i = i + 1: OName(i) = "^": PL(i) = 20
  239.     i = i + 1: OName(i) = "SQR": PL(i) = 20
  240.     i = i + 1: OName(i) = "ROOT": PL(i) = 20
  241.     'Multiplication and Division PL 30
  242.     i = i + 1: OName(i) = "*": PL(i) = 30
  243.     i = i + 1: OName(i) = "/": PL(i) = 30
  244.     'Integer Division PL 40
  245.     i = i + 1: OName(i) = "\": PL(i) = 40
  246.     'MOD PL 50
  247.     i = i + 1: OName(i) = "MOD": PL(i) = 50
  248.     'Addition and Subtraction PL 60
  249.     i = i + 1: OName(i) = "+": PL(i) = 60
  250.     i = i + 1: OName(i) = "-": PL(i) = 60
  251.  
  252.     'Relational Operators =, >, <, <>, <=, >=   PL 70
  253.     i = i + 1: OName(i) = "<>": PL(i) = 70 'These next three are just reversed symbols as an attempt to help process a common typo
  254.     i = i + 1: OName(i) = "><": PL(i) = 70
  255.     i = i + 1: OName(i) = "<=": PL(i) = 70
  256.     i = i + 1: OName(i) = ">=": PL(i) = 70
  257.     i = i + 1: OName(i) = "=<": PL(i) = 70 'I personally can never keep these things straight.  Is it < = or = <...
  258.     i = i + 1: OName(i) = "=>": PL(i) = 70 'Who knows, check both!
  259.     i = i + 1: OName(i) = ">": PL(i) = 70
  260.     i = i + 1: OName(i) = "<": PL(i) = 70
  261.     i = i + 1: OName(i) = "=": PL(i) = 70
  262.     'Logical Operations PL 80+
  263.     i = i + 1: OName(i) = "NOT": PL(i) = 80
  264.     i = i + 1: OName(i) = "AND": PL(i) = 90
  265.     i = i + 1: OName(i) = "OR": PL(i) = 100
  266.     i = i + 1: OName(i) = "XOR": PL(i) = 110
  267.     i = i + 1: OName(i) = "EQV": PL(i) = 120
  268.     i = i + 1: OName(i) = "IMP": PL(i) = 130
  269.     i = i + 1: OName(i) = ",": PL(i) = 1000
  270.  
  271.     REDIM _PRESERVE OName(i) AS STRING, PL(i) AS INTEGER
  272.  
  273. FUNCTION EvaluateNumbers$ (p, num() AS STRING)
  274.     DIM n1 AS _FLOAT, n2 AS _FLOAT, n3 AS _FLOAT
  275.     'PRINT "EVALNUM:"; OName(p), num(1), num(2)
  276.     IF INSTR(num(1), ",") THEN
  277.         EvaluateNumbers$ = "ERROR - Invalid comma (" + num(1) + ")": EXIT FUNCTION
  278.     END IF
  279.     l2 = INSTR(num(2), ",")
  280.     IF l2 THEN
  281.         SELECT CASE OName(p) 'only certain commands should pass a comma value
  282.             CASE "C_RG", "C_RA", "_RGB", "_RGBA", "_RED", "_GREEN", "C_BL", "_ALPHA"
  283.             CASE ELSE
  284.                 C$ = MID$(num(2), l2)
  285.                 num(2) = LEFT$(num(2), l2 - 1)
  286.         END SELECT
  287.     END IF
  288.  
  289.     SELECT CASE PL(p) 'divide up the work so we want do as much case checking
  290.         CASE 5 'Type conversions
  291.             'Note, these are special cases and work with the number BEFORE the command and not after
  292.             SELECT CASE OName(p) 'Depending on our operator..
  293.                 CASE "C_UOF": n1~%& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~%&)))
  294.                 CASE "C_ULO": n1%& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1%&)))
  295.                 CASE "C_UBY": n1~%% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~%%)))
  296.                 CASE "C_UIN": n1~% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~%)))
  297.                 CASE "C_BY": n1%% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1%%)))
  298.                 CASE "C_IN": n1% = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1%)))
  299.                 CASE "C_UIF": n1~&& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~&&)))
  300.                 CASE "C_OF": n1~& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~&)))
  301.                 CASE "C_IF": n1&& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1&&)))
  302.                 CASE "C_LO": n1& = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1&)))
  303.                 CASE "C_UBI": n1~` = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1~`)))
  304.                 CASE "C_BI": n1` = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1`)))
  305.                 CASE "C_FL": n1## = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1##)))
  306.                 CASE "C_DO": n1# = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1#)))
  307.                 CASE "C_SI": n1! = VAL(num(1)): EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1!)))
  308.             END SELECT
  309.             EXIT FUNCTION
  310.         CASE 10 'functions
  311.             SELECT CASE OName(p) 'Depending on our operator..
  312.                 CASE "_PI"
  313.                     n1 = 3.14159265358979323846264338327950288## 'Future compatable in case something ever stores extra digits for PI
  314.                     IF num(2) <> "" THEN n1 = n1 * VAL(num(2))
  315.                 CASE "_ACOS": n1 = _ACOS(VAL(num(2)))
  316.                 CASE "_ASIN": n1 = _ASIN(VAL(num(2)))
  317.                 CASE "_ARCSEC": n1 = _ARCSEC(VAL(num(2)))
  318.                 CASE "_ARCCSC": n1 = _ARCCSC(VAL(num(2)))
  319.                 CASE "_ARCCOT": n1 = _ARCCOT(VAL(num(2)))
  320.                 CASE "_SECH": n1 = _SECH(VAL(num(2)))
  321.                 CASE "_CSCH": n1 = _CSCH(VAL(num(2)))
  322.                 CASE "_COTH": n1 = _COTH(VAL(num(2)))
  323.                 CASE "C_RG"
  324.                     n$ = num(2)
  325.                     IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGB32": EXIT FUNCTION
  326.                     c1 = INSTR(n$, ",")
  327.                     IF c1 THEN c2 = INSTR(c1 + 1, n$, ",")
  328.                     IF c2 THEN c3 = INSTR(c2 + 1, n$, ",")
  329.                     IF c3 THEN c4 = INSTR(c3 + 1, n$, ",")
  330.                     IF c1 = 0 THEN 'there's no comma in the command to parse.  It's a grayscale value
  331.                         n = VAL(num(2))
  332.                         n1 = _RGB32(n, n, n)
  333.                     ELSEIF c2 = 0 THEN 'there's one comma and not 2.  It's grayscale with alpha.
  334.                         n = VAL(LEFT$(num(2), c1))
  335.                         n2 = VAL(MID$(num(2), c1 + 1))
  336.                         n1 = _RGBA32(n, n, n, n2)
  337.                     ELSEIF c3 = 0 THEN 'there's two commas.  It's _RGB values
  338.                         n = VAL(LEFT$(num(2), c1))
  339.                         n2 = VAL(MID$(num(2), c1 + 1))
  340.                         n3 = VAL(MID$(num(2), c2 + 1))
  341.                         n1 = _RGB32(n, n2, n3)
  342.                     ELSEIF c4 = 0 THEN 'there's three commas.  It's _RGBA values
  343.                         n = VAL(LEFT$(num(2), c1))
  344.                         n2 = VAL(MID$(num(2), c1 + 1))
  345.                         n3 = VAL(MID$(num(2), c2 + 1))
  346.                         n4 = VAL(MID$(num(2), c3 + 1))
  347.                         n1 = _RGBA32(n, n2, n3, n4)
  348.                     ELSE 'we have more than three commas.  I have no idea WTH type of values got passed here!
  349.                         EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT FUNCTION
  350.                     END IF
  351.                 CASE "C_RA"
  352.                     n$ = num(2)
  353.                     IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGBA32": EXIT FUNCTION
  354.                     c1 = INSTR(n$, ",")
  355.                     IF c1 THEN c2 = INSTR(c1 + 1, n$, ",")
  356.                     IF c2 THEN c3 = INSTR(c2 + 1, n$, ",")
  357.                     IF c3 THEN c4 = INSTR(c3 + 1, n$, ",")
  358.                     IF c3 = 0 OR c4 <> 0 THEN EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + ")": EXIT FUNCTION
  359.                     'we have to have 3 commas; not more, not less.
  360.                     n = VAL(LEFT$(num(2), c1))
  361.                     n2 = VAL(MID$(num(2), c1 + 1))
  362.                     n3 = VAL(MID$(num(2), c2 + 1))
  363.                     n4 = VAL(MID$(num(2), c3 + 1))
  364.                     n1 = _RGBA32(n, n2, n3, n4)
  365.                 CASE "_RGB"
  366.                     n$ = num(2)
  367.                     IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGB": EXIT FUNCTION
  368.                     c1 = INSTR(n$, ",")
  369.                     IF c1 THEN c2 = INSTR(c1 + 1, n$, ",")
  370.                     IF c2 THEN c3 = INSTR(c2 + 1, n$, ",")
  371.                     IF c3 THEN c4 = INSTR(c3 + 1, n$, ",")
  372.                     IF c3 = 0 OR c4 <> 0 THEN EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGB requires 4 parameters for Red, Green, Blue, ScreenMode.": EXIT FUNCTION
  373.                     'we have to have 3 commas; not more, not less.
  374.                     n = VAL(LEFT$(num(2), c1))
  375.                     n2 = VAL(MID$(num(2), c1 + 1))
  376.                     n3 = VAL(MID$(num(2), c2 + 1))
  377.                     n4 = VAL(MID$(num(2), c3 + 1))
  378.                     SELECT CASE n4
  379.                         CASE 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values
  380.                         CASE ELSE
  381.                             EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + STR$(n4) + ")": EXIT FUNCTION
  382.                     END SELECT
  383.                     t = _NEWIMAGE(1, 1, n4)
  384.                     n1 = _RGB(n, n2, n3, t)
  385.                     _FREEIMAGE t
  386.                 CASE "_RGBA"
  387.                     n$ = num(2)
  388.                     IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null _RGBA": EXIT FUNCTION
  389.                     c1 = INSTR(n$, ",")
  390.                     IF c1 THEN c2 = INSTR(c1 + 1, n$, ",")
  391.                     IF c2 THEN c3 = INSTR(c2 + 1, n$, ",")
  392.                     IF c3 THEN c4 = INSTR(c3 + 1, n$, ",")
  393.                     IF c4 THEN c5 = INSTR(c4 + 1, n$, ",")
  394.                     IF c4 = 0 OR c5 <> 0 THEN EvaluateNumbers$ = "ERROR - Invalid comma count (" + num(2) + "). _RGBA requires 5 parameters for Red, Green, Blue, Alpha, ScreenMode.": EXIT FUNCTION
  395.                     'we have to have 4 commas; not more, not less.
  396.                     n = VAL(LEFT$(num(2), c1))
  397.                     n2 = VAL(MID$(num(2), c1 + 1))
  398.                     n3 = VAL(MID$(num(2), c2 + 1))
  399.                     n4 = VAL(MID$(num(2), c3 + 1))
  400.                     n5 = VAL(MID$(num(2), c4 + 1))
  401.                     SELECT CASE n5
  402.                         CASE 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values
  403.                         CASE ELSE
  404.                             EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + STR$(n5) + ")": EXIT FUNCTION
  405.                     END SELECT
  406.                     t = _NEWIMAGE(1, 1, n5)
  407.                     n1 = _RGBA(n, n2, n3, n4, t)
  408.                     _FREEIMAGE t
  409.                 CASE "_RED", "_GREEN", "_BLUE", "_ALPHA"
  410.                     n$ = num(2)
  411.                     IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT FUNCTION
  412.                     c1 = INSTR(n$, ",")
  413.                     IF c1 = 0 THEN EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT FUNCTION
  414.                     IF c1 THEN c2 = INSTR(c1 + 1, n$, ",")
  415.                     IF c2 THEN EvaluateNumbers$ = "ERROR - " + OName(p) + " requires 2 parameters for Color, ScreenMode.": EXIT FUNCTION
  416.                     n = VAL(LEFT$(num(2), c1))
  417.                     n2 = VAL(MID$(num(2), c1 + 1))
  418.                     SELECT CASE n2
  419.                         CASE 0 TO 2, 7 TO 13, 256, 32 'these are the good screen values
  420.                         CASE ELSE
  421.                             EvaluateNumbers$ = "ERROR - Invalid Screen Mode (" + STR$(n2) + ")": EXIT FUNCTION
  422.                     END SELECT
  423.                     t = _NEWIMAGE(1, 1, n4)
  424.                     SELECT CASE OName(p)
  425.                         CASE "_RED": n1 = _RED(n, t)
  426.                         CASE "_BLUE": n1 = _BLUE(n, t)
  427.                         CASE "_GREEN": n1 = _GREEN(n, t)
  428.                         CASE "_ALPHA": n1 = _ALPHA(n, t)
  429.                     END SELECT
  430.                     _FREEIMAGE t
  431.                 CASE "C_RX", "C_GR", "C_BL", "C_AL"
  432.                     n$ = num(2)
  433.                     IF n$ = "" THEN EvaluateNumbers$ = "ERROR - Invalid null " + OName(p): EXIT FUNCTION
  434.                     n = VAL(num(2))
  435.                     SELECT CASE OName(p)
  436.                         CASE "C_RX": n1 = _RED32(n)
  437.                         CASE "C_BL": n1 = _BLUE32(n)
  438.                         CASE "C_GR": n1 = _GREEN32(n)
  439.                         CASE "C_AL": n1 = _ALPHA32(n)
  440.                     END SELECT
  441.                 CASE "COS": n1 = COS(VAL(num(2)))
  442.                 CASE "SIN": n1 = SIN(VAL(num(2)))
  443.                 CASE "TAN": n1 = TAN(VAL(num(2)))
  444.                 CASE "LOG": n1 = LOG(VAL(num(2)))
  445.                 CASE "EXP": n1 = EXP(VAL(num(2)))
  446.                 CASE "ATN": n1 = ATN(VAL(num(2)))
  447.                 CASE "_D2R": n1 = 0.0174532925 * (VAL(num(2)))
  448.                 CASE "_D2G": n1 = 1.1111111111 * (VAL(num(2)))
  449.                 CASE "_R2D": n1 = 57.2957795 * (VAL(num(2)))
  450.                 CASE "_R2G": n1 = 0.015707963 * (VAL(num(2)))
  451.                 CASE "_G2D": n1 = 0.9 * (VAL(num(2)))
  452.                 CASE "_G2R": n1 = 63.661977237 * (VAL(num(2)))
  453.                 CASE "ABS": n1 = ABS(VAL(num(2)))
  454.                 CASE "SGN": n1 = SGN(VAL(num(2)))
  455.                 CASE "INT": n1 = INT(VAL(num(2)))
  456.                 CASE "_ROUND": n1 = _ROUND(VAL(num(2)))
  457.                 CASE "_CEIL": n1 = _CEIL(VAL(num(2)))
  458.                 CASE "FIX": n1 = FIX(VAL(num(2)))
  459.                 CASE "_SEC": n1 = _SEC(VAL(num(2)))
  460.                 CASE "_CSC": n1 = _CSC(VAL(num(2)))
  461.                 CASE "_COT": n1 = _COT(VAL(num(2)))
  462.             END SELECT
  463.         CASE 20 TO 60 'Math Operators
  464.             SELECT CASE OName(p) 'Depending on our operator..
  465.                 CASE "^": n1 = VAL(num(1)) ^ VAL(num(2))
  466.                 CASE "SQR": n1 = SQR(VAL(num(2)))
  467.                 CASE "ROOT"
  468.                     n1 = VAL(num(1)): n2 = VAL(num(2))
  469.                     IF n2 = 1 THEN EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))): EXIT FUNCTION
  470.                     IF n1 < 0 AND n2 >= 1 THEN sign = -1: n1 = -n1 ELSE sign = 1
  471.                     n3 = 1## / n2
  472.                     IF n3 <> INT(n3) AND n2 < 1 THEN sign = SGN(n1): n1 = ABS(n1)
  473.                     n1 = sign * (n1 ^ n3)
  474.                 CASE "*": n1 = VAL(num(1)) * VAL(num(2))
  475.                 CASE "/": n1 = VAL(num(1)) / VAL(num(2))
  476.                 CASE "\"
  477.                     IF VAL(num(2)) <> 0 THEN
  478.                         n1 = VAL(num(1)) \ VAL(num(2))
  479.                     ELSE
  480.                         EvaluateNumbers$ = "ERROR - Bad operation (We shouldn't see this)"
  481.                         EXIT FUNCTION
  482.                     END IF
  483.                 CASE "MOD": n1 = VAL(num(1)) MOD VAL(num(2))
  484.                 CASE "+": n1 = VAL(num(1)) + VAL(num(2))
  485.                 CASE "-":
  486.                     n1 = VAL(num(1)) - VAL(num(2))
  487.             END SELECT
  488.         CASE 70 'Relational Operators =, >, <, <>, <=, >=
  489.             SELECT CASE OName(p) 'Depending on our operator..
  490.                 CASE "=": n1 = VAL(num(1)) = VAL(num(2))
  491.                 CASE ">": n1 = VAL(num(1)) > VAL(num(2))
  492.                 CASE "<": n1 = VAL(num(1)) < VAL(num(2))
  493.                 CASE "<>", "><": n1 = VAL(num(1)) <> VAL(num(2))
  494.                 CASE "<=", "=<": n1 = VAL(num(1)) <= VAL(num(2))
  495.                 CASE ">=", "=>": n1 = VAL(num(1)) >= VAL(num(2))
  496.             END SELECT
  497.         CASE ELSE 'a value we haven't processed elsewhere
  498.             SELECT CASE OName(p) 'Depending on our operator..
  499.                 CASE "NOT": n1 = NOT VAL(num(2))
  500.                 CASE "AND": n1 = VAL(num(1)) AND VAL(num(2))
  501.                 CASE "OR": n1 = VAL(num(1)) OR VAL(num(2))
  502.                 CASE "XOR": n1 = VAL(num(1)) XOR VAL(num(2))
  503.                 CASE "EQV": n1 = VAL(num(1)) EQV VAL(num(2))
  504.                 CASE "IMP": n1 = VAL(num(1)) IMP VAL(num(2))
  505.             END SELECT
  506.     END SELECT
  507.  
  508.     EvaluateNumbers$ = RTRIM$(LTRIM$(STR$(n1))) + C$
  509.  
  510.     'PRINT "AFTEREVN:"; EvaluateNumbers$
  511.  
  512. FUNCTION DWD$ (EXP$) 'Deal With Duplicates
  513.     'To deal with duplicate operators in our code.
  514.     'Such as --  becomes a +
  515.     '++ becomes a +
  516.     '+- becomes a -
  517.     '-+ becomes a -
  518.     t$ = EXP$
  519.     DO
  520.         bad = 0
  521.         DO
  522.             l = INSTR(t$, "++")
  523.             IF l THEN t$ = LEFT$(t$, l - 1) + "+" + MID$(t$, l + 2): bad = -1
  524.         LOOP UNTIL l = 0
  525.         DO
  526.             l = INSTR(t$, "+-")
  527.             IF l THEN t$ = LEFT$(t$, l - 1) + "-" + MID$(t$, l + 2): bad = -1
  528.         LOOP UNTIL l = 0
  529.         DO
  530.             l = INSTR(t$, "-+")
  531.             IF l THEN t$ = LEFT$(t$, l - 1) + "-" + MID$(t$, l + 2): bad = -1
  532.         LOOP UNTIL l = 0
  533.         DO
  534.             l = INSTR(t$, "--")
  535.             IF l THEN t$ = LEFT$(t$, l - 1) + "+" + MID$(t$, l + 2): bad = -1
  536.         LOOP UNTIL l = 0
  537.         'PRINT "FIXING: "; t$
  538.     LOOP UNTIL NOT bad
  539.     DWD$ = t$
  540.  
  541. SUB PreParse (e$)
  542.     DIM f AS _FLOAT
  543.  
  544.     IF PP_TypeMod(0) = "" THEN
  545.         REDIM PP_TypeMod(100) AS STRING, PP_ConvertedMod(100) AS STRING 'Large enough to hold all values to begin with
  546.         PP_TypeMod(0) = "Initialized" 'Set so we don't do this section over and over, as we keep the values in shared memory.
  547.         Set_OrderOfOperations 'Call this once to set up our proper order of operations and variable list
  548.         'and the below is a conversion list so symbols don't get cross confused.
  549.         i = i + 1: PP_TypeMod(i) = "~`": PP_ConvertedMod(i) = "C_UBI" 'unsigned bit
  550.         i = i + 1: PP_TypeMod(i) = "~%%": PP_ConvertedMod(i) = "C_UBY" 'unsigned byte
  551.         i = i + 1: PP_TypeMod(i) = "~%&": PP_ConvertedMod(i) = "C_UOF" 'unsigned offset
  552.         i = i + 1: PP_TypeMod(i) = "~%": PP_ConvertedMod(i) = "C_UIN" 'unsigned integer
  553.         i = i + 1: PP_TypeMod(i) = "~&&": PP_ConvertedMod(i) = "C_UIF" 'unsigned integer64
  554.         i = i + 1: PP_TypeMod(i) = "~&": PP_ConvertedMod(i) = "C_ULO" 'unsigned long
  555.         i = i + 1: PP_TypeMod(i) = "`": PP_ConvertedMod(i) = "C_BI" 'bit
  556.         i = i + 1: PP_TypeMod(i) = "%%": PP_ConvertedMod(i) = "C_BY" 'byte
  557.         i = i + 1: PP_TypeMod(i) = "%&": PP_ConvertedMod(i) = "C_OF" 'offset
  558.         i = i + 1: PP_TypeMod(i) = "%": PP_ConvertedMod(i) = "C_IN" 'integer
  559.         i = i + 1: PP_TypeMod(i) = "&&": PP_ConvertedMod(i) = "C_IF" 'integer64
  560.         i = i + 1: PP_TypeMod(i) = "&": PP_ConvertedMod(i) = "C_LO" 'long
  561.         i = i + 1: PP_TypeMod(i) = "!": PP_ConvertedMod(i) = "C_SI" 'single
  562.         i = i + 1: PP_TypeMod(i) = "##": PP_ConvertedMod(i) = "C_FL" 'float
  563.         i = i + 1: PP_TypeMod(i) = "#": PP_ConvertedMod(i) = "C_DO" 'double
  564.         i = i + 1: PP_TypeMod(i) = "_RGB32": PP_ConvertedMod(i) = "C_RG" 'rgb32
  565.         i = i + 1: PP_TypeMod(i) = "_RGBA32": PP_ConvertedMod(i) = "C_RA" 'rgba32
  566.         i = i + 1: PP_TypeMod(i) = "_RED32": PP_ConvertedMod(i) = "C_RX" 'red32
  567.         i = i + 1: PP_TypeMod(i) = "_GREEN32": PP_ConvertedMod(i) = "C_GR" 'green32
  568.         i = i + 1: PP_TypeMod(i) = "_BLUE32": PP_ConvertedMod(i) = "C_BL" 'blue32
  569.         i = i + 1: PP_TypeMod(i) = "_ALPHA32": PP_ConvertedMod(i) = "C_AL" 'alpha32
  570.         REDIM _PRESERVE PP_TypeMod(i) AS STRING, PP_ConvertedMod(i) AS STRING 'And then resized to just contain the necessary space in memory
  571.     END IF
  572.     t$ = e$
  573.  
  574.     'First strip all spaces
  575.     t$ = ""
  576.     FOR i = 1 TO LEN(e$)
  577.         IF MID$(e$, i, 1) <> " " THEN t$ = t$ + MID$(e$, i, 1)
  578.     NEXT
  579.  
  580.     t$ = UCASE$(t$)
  581.     IF t$ = "" THEN e$ = "ERROR -- NULL string; nothing to evaluate": EXIT SUB
  582.  
  583.     'ERROR CHECK by counting our brackets
  584.     l = 0
  585.     DO
  586.         l = INSTR(l + 1, t$, "("): IF l THEN c = c + 1
  587.     LOOP UNTIL l = 0
  588.     l = 0
  589.     DO
  590.         l = INSTR(l + 1, t$, ")"): IF l THEN c1 = c1 + 1
  591.     LOOP UNTIL l = 0
  592.     IF c <> c1 THEN e$ = "ERROR -- Bad Parenthesis:" + STR$(c) + "( vs" + STR$(c1) + ")": EXIT SUB
  593.  
  594.     'Modify so that NOT will process properly
  595.     l = 0
  596.     DO
  597.         l = INSTR(l + 1, t$, "NOT")
  598.         IF l THEN
  599.             'We need to work magic on the statement so it looks pretty.
  600.             ' 1 + NOT 2 + 1 is actually processed as 1 + (NOT 2 + 1)
  601.             'Look for something not proper
  602.             l1 = INSTR(l + 1, t$, "AND")
  603.             IF l1 = 0 OR (INSTR(l + 1, t$, "OR") > 0 AND INSTR(l + 1, t$, "OR") < l1) THEN l1 = INSTR(l + 1, t$, "OR")
  604.             IF l1 = 0 OR (INSTR(l + 1, t$, "XOR") > 0 AND INSTR(l + 1, t$, "XOR") < l1) THEN l1 = INSTR(l + 1, t$, "XOR")
  605.             IF l1 = 0 OR (INSTR(l + 1, t$, "EQV") > 0 AND INSTR(l + 1, t$, "EQV") < l1) THEN l1 = INSTR(l + 1, t$, "EQV")
  606.             IF l1 = 0 OR (INSTR(l + 1, t$, "IMP") > 0 AND INSTR(l + 1, t$, "IMP") < l1) THEN l1 = INSTR(l + 1, t$, "IMP")
  607.             IF l1 = 0 THEN l1 = LEN(t$) + 1
  608.             t$ = LEFT$(t$, l - 1) + "(" + MID$(t$, l, l1 - l) + ")" + MID$(t$, l + l1 - l)
  609.             l = l + 3
  610.             'PRINT t$
  611.         END IF
  612.     LOOP UNTIL l = 0
  613.  
  614.     FOR j = 1 TO UBOUND(PP_TypeMod)
  615.         l = 0
  616.         DO
  617.             l = INSTR(l + 1, t$, PP_TypeMod(j))
  618.             IF l = 0 THEN EXIT DO
  619.             i = 0: l1 = 0: l2 = 0: lo = LEN(PP_TypeMod(j))
  620.             DO
  621.                 IF PL(i) > 10 THEN
  622.                     l2 = _INSTRREV(l, t$, OName$(i))
  623.                     IF l2 > 0 AND l2 > l1 THEN l1 = l2
  624.                 END IF
  625.                 i = i + lo
  626.             LOOP UNTIL i > UBOUND(PL)
  627.             'PRINT "L1:"; l1; "L"; l
  628.             l$ = LEFT$(t$, l1)
  629.             m$ = MID$(t$, l1 + 1, l - l1 - 1)
  630.             r$ = PP_ConvertedMod(j) + MID$(t$, l + lo)
  631.             'PRINT "Y$: "; TypeMod(j)
  632.             'PRINT "L$: "; l$
  633.             'PRINT "M$: "; m$
  634.             'PRINT "R$: "; r$
  635.             IF j > 15 THEN
  636.                 t$ = l$ + m$ + r$ 'replacement routine for commands which might get confused with others, like _RGB and _RGB32
  637.             ELSE
  638.                 'the first 15 commands need to properly place the parenthesis around the value we want to convert.
  639.                 t$ = l$ + "(" + m$ + ")" + r$
  640.             END IF
  641.             'PRINT "T$: "; t$
  642.             l = l + 2 + LEN(PP_TypeMod(j)) 'move forward from the length of the symbol we checked + the new "(" and  ")"
  643.         LOOP
  644.     NEXT
  645.     '    PRINT "HERE: "; t$
  646.  
  647.  
  648.  
  649.     'Check for bad operators before a ( bracket
  650.     l = 0
  651.     DO
  652.         l = INSTR(l + 1, t$, "(")
  653.         IF l AND l > 2 THEN 'Don't check the starting bracket; there's nothing before it.
  654.             good = 0
  655.             'PRINT "BEFORE: "; t$; l
  656.             FOR i = 1 TO UBOUND(OName)
  657.                 m$ = MID$(t$, l - LEN(OName(i)), LEN(OName(i)))
  658.                 'IF OName(i) = "C_SI" THEN PRINT "CONVERT TO SINGLE", m$
  659.                 IF m$ = OName(i) THEN good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI)
  660.             NEXT
  661.             'PRINT t$; l
  662.             IF NOT good THEN e$ = "ERROR - Improper operations before (.": EXIT SUB
  663.             l = l + 1
  664.         END IF
  665.     LOOP UNTIL l = 0
  666.  
  667.     'Check for bad operators after a ) bracket
  668.     l = 0
  669.     DO
  670.         l = INSTR(l + 1, t$, ")")
  671.         IF l AND l < LEN(t$) THEN
  672.             good = 0
  673.             FOR i = 1 TO UBOUND(oname)
  674.                 m$ = MID$(t$, l + 1, LEN(OName(i)))
  675.                 IF m$ = OName(i) THEN good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI
  676.             NEXT
  677.             IF MID$(t$, l + 1, 1) = ")" THEN good = -1
  678.             IF NOT good THEN e$ = "ERROR - Improper operations after ).": EXIT SUB
  679.             l = l + 1
  680.         END IF
  681.     LOOP UNTIL l = 0 OR l = LEN(t$) 'last symbol is a bracket
  682.  
  683.     'Turn all &H (hex) numbers into decimal values for the program to process properly
  684.     l = 0
  685.     DO
  686.         l = INSTR(t$, "&H")
  687.         IF l THEN
  688.             E = l + 1: finished = 0
  689.             DO
  690.                 E = E + 1
  691.                 comp$ = MID$(t$, E, 1)
  692.                 SELECT CASE comp$
  693.                     CASE "0" TO "9", "A" TO "F" 'All is good, our next digit is a number, continue to add to the hex$
  694.                     CASE ELSE
  695.                         good = 0
  696.                         FOR i = 1 TO UBOUND(oname)
  697.                             IF MID$(t$, E, LEN(OName(i))) = OName(i) AND PL(i) > 1 AND PL(i) <= 250 THEN good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI)
  698.                         NEXT
  699.                         IF NOT good THEN e$ = "ERROR - Improper &H value. (" + comp$ + ")": EXIT SUB
  700.                         E = E - 1
  701.                         finished = -1
  702.                 END SELECT
  703.             LOOP UNTIL finished OR E = LEN(t$)
  704.             t$ = LEFT$(t$, l - 1) + LTRIM$(RTRIM$(STR$(VAL(MID$(t$, l, E - l + 1))))) + MID$(t$, E + 1)
  705.         END IF
  706.     LOOP UNTIL l = 0
  707.  
  708.     'Turn all &B (binary) numbers into decimal values for the program to process properly
  709.     l = 0
  710.     DO
  711.         l = INSTR(t$, "&B")
  712.         IF l THEN
  713.             E = l + 1: finished = 0
  714.             DO
  715.                 E = E + 1
  716.                 comp$ = MID$(t$, E, 1)
  717.                 SELECT CASE comp$
  718.                     CASE "0", "1" 'All is good, our next digit is a number, continue to add to the hex$
  719.                     CASE ELSE
  720.                         good = 0
  721.                         FOR i = 1 TO UBOUND(oname)
  722.                             IF MID$(t$, E, LEN(OName(i))) = OName(i) AND PL(i) > 1 AND PL(i) <= 250 THEN good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI)
  723.                         NEXT
  724.                         IF NOT good THEN e$ = "ERROR - Improper &B value. (" + comp$ + ")": EXIT SUB
  725.                         E = E - 1
  726.                         finished = -1
  727.                 END SELECT
  728.             LOOP UNTIL finished OR E = LEN(t$)
  729.             bin$ = MID$(t$, l + 2, E - l - 1)
  730.             FOR i = 1 TO LEN(bin$)
  731.                 IF MID$(bin$, i, 1) = "1" THEN f = f + 2 ^ (LEN(bin$) - i)
  732.             NEXT
  733.             t$ = LEFT$(t$, l - 1) + LTRIM$(RTRIM$(STR$(f))) + MID$(t$, E + 1)
  734.         END IF
  735.     LOOP UNTIL l = 0
  736.  
  737.     'PRINT "ALMOST:"; t$
  738.  
  739.     t$ = N2S(t$)
  740.     'PRINT "ALMOST2:"; t$
  741.     VerifyString t$
  742.     'PRINT "Out of PreParse: "; e$
  743.     e$ = t$
  744.  
  745.  
  746.  
  747. SUB VerifyString (t$)
  748.     'ERROR CHECK for unrecognized operations
  749.     j = 1
  750.     DO
  751.         comp$ = MID$(t$, j, 1)
  752.         SELECT CASE comp$
  753.             CASE "0" TO "9", ".", "(", ")", ",": j = j + 1
  754.             CASE ELSE
  755.                 good = 0
  756.                 FOR i = 1 TO UBOUND(OName)
  757.                     IF MID$(t$, j, LEN(OName(i))) = OName(i) THEN good = -1: EXIT FOR 'We found an operator after our ), and it's not a CONST (like PI)
  758.                 NEXT
  759.                 IF NOT good THEN t$ = "ERROR - Bad Operational value. (" + comp$ + ")": EXIT SUB
  760.                 j = j + LEN(OName(i))
  761.         END SELECT
  762.     LOOP UNTIL j > LEN(t$)
  763.  
  764. FUNCTION N2S$ (EXP$) 'scientific Notation to String
  765.  
  766.     'PRINT "Before notation:"; exp$
  767.  
  768.     t$ = LTRIM$(RTRIM$(EXP$))
  769.     IF LEFT$(t$, 1) = "-" OR LEFT$(t$, 1) = "N" THEN sign$ = "-": t$ = MID$(t$, 2)
  770.  
  771.     dp = INSTR(t$, "D+"): dm = INSTR(t$, "D-")
  772.     ep = INSTR(t$, "E+"): em = INSTR(t$, "E-")
  773.     check1 = SGN(dp) + SGN(dm) + SGN(ep) + SGN(em)
  774.     IF check1 < 1 OR check1 > 1 THEN N2S = EXP$: EXIT SUB 'If no scientic notation is found, or if we find more than 1 type, it's not SN!
  775.  
  776.     SELECT CASE l 'l now tells us where the SN starts at.
  777.         CASE IS < dp: l = dp
  778.         CASE IS < dm: l = dm
  779.         CASE IS < ep: l = ep
  780.         CASE IS < em: l = em
  781.     END SELECT
  782.  
  783.     l$ = LEFT$(t$, l - 1) 'The left of the SN
  784.     r$ = MID$(t$, l + 1): r&& = VAL(r$) 'The right of the SN, turned into a workable long
  785.  
  786.  
  787.     IF INSTR(l$, ".") THEN 'Location of the decimal, if any
  788.         IF r&& > 0 THEN
  789.             r&& = r&& - LEN(l$) + 2
  790.         ELSE
  791.             r&& = r&& + 1
  792.         END IF
  793.         l$ = LEFT$(l$, 1) + MID$(l$, 3)
  794.     END IF
  795.  
  796.     SELECT CASE r&&
  797.         CASE 0 'what the heck? We solved it already?
  798.             'l$ = l$
  799.         CASE IS < 0
  800.             FOR i = 1 TO -r&&
  801.                 l$ = "0" + l$
  802.             NEXT
  803.             l$ = "0." + l$
  804.         CASE ELSE
  805.             FOR i = 1 TO r&&
  806.                 l$ = l$ + "0"
  807.             NEXT
  808.     END SELECT
  809.  
  810.     N2S$ = sign$ + l$
  811.     'PRINT "After notation:"; N2S$
  812.  

MathEval.png

5
Utilities / Ellipse Intersecting Line by STxAxTIC
« on: March 05, 2020, 11:42:02 pm »
Ellipse Intersecting Line

Author: @STxAxTIC
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2143.0
Version: 2020
Tags: [2d], [geometry], [intersections]

Description:
In response to

https://www.qb64.org/forum/index.php?topic=2132

... all I could think is "why stop at circles when you can do ellipses?"


Source Code:
Code: QB64: [Select]
  1.  
  2. xorig = 0
  3. yorig = 0
  4.  
  5. CALL cline(xorig, yorig, xorig + _WIDTH, yorig, 8)
  6. CALL cline(xorig, yorig, xorig + -_WIDTH, yorig, 8)
  7. CALL cline(xorig, yorig, xorig, yorig + _HEIGHT, 8)
  8. CALL cline(xorig, yorig, xorig, yorig - _HEIGHT, 8)
  9.  
  10. xzoom = 20
  11. yzoom = 20
  12.  
  13. ' Initialize line
  14. b = -2
  15. d = 2
  16. lineang = .1
  17. vx = COS(lineang)
  18. vy = SIN(lineang)
  19. m = vy / vx
  20.  
  21. ' Initialize ellipse
  22. x0 = 2
  23. y0 = -2
  24. ellipsearg = .2
  25. amag = 10
  26. ax = amag * COS(ellipsearg)
  27. ay = amag * SIN(ellipsearg)
  28. bmag = 5
  29. bx = bmag * COS(ellipsearg + 3.14 / 2)
  30. by = bmag * SIN(ellipsearg + 3.14 / 2)
  31.  
  32.  
  33.         x = _MOUSEX
  34.         y = _MOUSEY
  35.         IF ((x > 0) AND (x < _WIDTH) AND (y > 0) AND (y < _HEIGHT)) THEN
  36.             IF _MOUSEBUTTON(1) THEN
  37.                 x = _MOUSEX
  38.                 y = _MOUSEY
  39.                 x0 = (x - _WIDTH / 2) / xzoom
  40.                 y0 = (-y + _HEIGHT / 2) / yzoom
  41.             END IF
  42.             IF _MOUSEBUTTON(2) THEN
  43.                 x = _MOUSEX
  44.                 y = _MOUSEY
  45.                 d = (x - _WIDTH / 2) / xzoom
  46.                 b = (-y + _HEIGHT / 2) / yzoom
  47.             END IF
  48.             IF _MOUSEWHEEL > 0 THEN
  49.                 lineang = lineang + .01
  50.                 vx = COS(lineang)
  51.                 vy = SIN(lineang)
  52.                 m = vy / vx
  53.             END IF
  54.             IF _MOUSEWHEEL < 0 THEN
  55.                 lineang = lineang - .01
  56.                 vx = COS(lineang)
  57.                 vy = SIN(lineang)
  58.                 m = vy / vx
  59.             END IF
  60.         END IF
  61.     LOOP
  62.  
  63.         CASE 18432
  64.             bmag = bmag + .1
  65.             bx = bmag * COS(ellipsearg + 3.14 / 2)
  66.             by = bmag * SIN(ellipsearg + 3.14 / 2)
  67.         CASE 20480
  68.             bmag = bmag - .1
  69.             bx = bmag * COS(ellipsearg + 3.14 / 2)
  70.             by = bmag * SIN(ellipsearg + 3.14 / 2)
  71.         CASE 19200
  72.             ellipsearg = ellipsearg - .1
  73.             ax = amag * COS(ellipsearg)
  74.             ay = amag * SIN(ellipsearg)
  75.             bx = bmag * COS(ellipsearg + 3.14 / 2)
  76.             by = bmag * SIN(ellipsearg + 3.14 / 2)
  77.         CASE 19712
  78.             ellipsearg = ellipsearg + .1
  79.             ax = amag * COS(ellipsearg)
  80.             ay = amag * SIN(ellipsearg)
  81.             bx = bmag * COS(ellipsearg + 3.14 / 2)
  82.             by = bmag * SIN(ellipsearg + 3.14 / 2)
  83.     END SELECT
  84.  
  85.     ' Intersections
  86.     a2 = ax ^ 2 + ay ^ 2
  87.     b2 = bx ^ 2 + by ^ 2
  88.     av = ax * vx + ay * vy
  89.     bv = bx * vx + by * vy
  90.     rbx = d - x0
  91.     rby = b - y0
  92.     adbr = ax * rbx + ay * rby
  93.     bdbr = bx * rbx + by * rby
  94.     aa = av ^ 2 / a2 ^ 2 + bv ^ 2 / b2 ^ 2
  95.     bb = 2 * (av * adbr / a2 ^ 2 + bv * bdbr / b2 ^ 2)
  96.     cc = adbr ^ 2 / a2 ^ 2 + bdbr ^ 2 / b2 ^ 2 - 1
  97.     arg = bb ^ 2 - 4 * aa * cc
  98.     IF (arg > 0) THEN
  99.         alpha1 = (-bb + SQR(arg)) / (2 * aa)
  100.         alpha2 = (-bb - SQR(arg)) / (2 * aa)
  101.         x1 = alpha1 * vx + d
  102.         x2 = alpha2 * vx + d
  103.         y1 = alpha1 * vy + b
  104.         y2 = alpha2 * vy + b
  105.     ELSE
  106.         x1 = -999
  107.         y1 = -999
  108.         x2 = -999
  109.         y2 = -999
  110.     END IF
  111.  
  112.     GOSUB draweverything
  113.  
  114.     _LIMIT 60
  115.     _DISPLAY
  116.  
  117.  
  118. draweverything:
  119. PAINT (1, 1), 15
  120. COLOR 0, 15
  121. LOCATE 1, 1: PRINT "LClick=Move ellipse, RClick=Move line, Scroll=Tilt line, Arrows=Shift ellipse"
  122. FOR alpha = -20 TO 20 STEP .001
  123.     x = alpha * vx + d
  124.     y = alpha * vy + b
  125.     CALL ccircle(xorig + x * xzoom, yorig + y * yzoom, 1, 1)
  126. FOR t = 0 TO 6.284 STEP .001
  127.     x = x0 + ax * COS(t) + bx * SIN(t)
  128.     y = y0 + ay * COS(t) + by * SIN(t)
  129.     CALL ccircle(xorig + x * xzoom, yorig + y * yzoom, 1, 4)
  130. CALL ccircle(xorig + x1 * xzoom, yorig + y1 * yzoom, 10, 1)
  131. CALL ccircle(xorig + x2 * xzoom, yorig + y2 * yzoom, 10, 1)
  132.  
  133. SUB cline (x1, y1, x2, y2, col)
  134.     LINE (_WIDTH / 2 + x1, -y1 + _HEIGHT / 2)-(_WIDTH / 2 + x2, -y2 + _HEIGHT / 2), col
  135.  
  136. SUB ccircle (x1, y1, r, col)
  137.     CIRCLE (_WIDTH / 2 + x1, -y1 + _HEIGHT / 2), r, col
  138.  

Ellipse Intersect Line.png

6
Utilities / Circle Intersecting Line by bplus
« on: March 05, 2020, 11:35:49 pm »
Circle Intersecting Line

Author: @bplus
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2132.0
Version: 2020
Tags: [2d], [geometry], [intersections]

Description:
This is an interactive (mouse-driven) demo that calculates the intersection of any line with any circle.

Source Code:
Code: QB64: [Select]
  1. _TITLE "Circle Intersect Line" ' b+ 2020-01-31 develop
  2. ' Find point on line perpendicular to line at another point" 'B+ 2019-12-15
  3. ' further for a Line and Circle Intersect, making full use of the information from the link below.
  4.  
  5. CONST xmax = 800, ymax = 600
  6. SCREEN _NEWIMAGE(xmax, ymax, 32)
  7. _SCREENMOVE 300, 40
  8.  
  9.     CLS
  10.     IF testTangent = 0 THEN 'test plug in set of border conditions not easy to click
  11.         PRINT "First set here is a plug in test set for vertical lines."
  12.         mx(1) = 200: my(1) = 100: mx(2) = 200: my(2) = 400 'line  x = 200
  13.         mx(3) = 400: my(3) = 300: mx(4) = 150: my(4) = 300 ' circle origin (center 400, 300) then radius test 200 tangent, 150 more than tangent, 250 short
  14.         FOR i = 1 TO 4
  15.             CIRCLE (mx(i), my(i)), 2
  16.         NEXT
  17.         IF mx(1) <> mx(2) THEN
  18.             slopeYintersect mx(1), my(1), mx(2), my(2), m, Y0 ' Y0 otherwise know as y Intersect
  19.             LINE (0, Y0)-(xmax, m * xmax + Y0), &HFF0000FF
  20.             LINE (mx(1), my(1))-(mx(2), my(2))
  21.         ELSE
  22.             LINE (mx(1), 0)-(mx(1), ymax), &HFF0000FF
  23.             LINE (mx(1), my(1))-(mx(2), my(2))
  24.         END IF
  25.         testTangent = 1
  26.     ELSE
  27.         PRINT "First 2 clicks will form a line, 3rd the circle origin and 4th the circle radius:"
  28.         WHILE pi < 4 'get 4 mouse clicks
  29.             _PRINTSTRING (20, 20), SPACE$(20)
  30.             _PRINTSTRING (20, 20), "Need 4 clicks, have" + STR$(pi)
  31.             WHILE _MOUSEINPUT: WEND
  32.             IF _MOUSEBUTTON(1) AND oldMouse = 0 THEN 'new mouse down
  33.                 pi = pi + 1
  34.                 mx(pi) = _MOUSEX: my(pi) = _MOUSEY
  35.                 CIRCLE (mx(pi), my(pi)), 2
  36.                 IF pi = 2 THEN 'draw first line segment then line
  37.                     IF mx(1) <> mx(2) THEN
  38.                         slopeYintersect mx(1), my(1), mx(2), my(2), m, Y0 ' Y0 otherwise know as y Intersect
  39.                         LINE (0, Y0)-(xmax, m * xmax + Y0), &HFF0000FF
  40.                         LINE (mx(1), my(1))-(mx(2), my(2))
  41.                     ELSE
  42.                         LINE (mx(1), 0)-(mx(1), ymax), &HFF0000FF
  43.                         LINE (mx(1), my(1))-(mx(2), my(2))
  44.                     END IF
  45.                 END IF
  46.             END IF
  47.             oldMouse = _MOUSEBUTTON(1)
  48.             _DISPLAY
  49.             _LIMIT 60
  50.         WEND
  51.     END IF
  52.     p = mx(3): q = my(3)
  53.     r = SQR((mx(3) - mx(4)) ^ 2 + (my(3) - my(4)) ^ 2)
  54.     CIRCLE (p, q), r, &HFFFF0000
  55.     IF mx(1) = mx(2) THEN 'line is vertical so if r =
  56.         IF r = ABS(mx(1) - mx(3)) THEN ' one point tangent intersect
  57.             PRINT "Tangent point is "; TS$(mx(1)); ", "; TS$(my(3))
  58.             CIRCLE (mx(1), my(3)), 2, &HFFFFFF00
  59.             CIRCLE (mx(1), my(3)), 4, &HFFFFFF00
  60.         ELSEIF r < ABS(mx(1) - mx(3)) THEN 'no intersect
  61.             PRINT "No intersect, radius too small."
  62.         ELSE '2 point intersect
  63.             ydist = SQR(r ^ 2 - (mx(1) - mx(3)) ^ 2)
  64.             y1 = my(3) + ydist
  65.             y2 = my(3) - ydist
  66.             PRINT "2 Point intersect (x1, y1) = "; TS$(mx(1)); ", "; TS$(y1); "  (x2, y2) = "; TS$(mx(1)); ", "; TS$(y2)
  67.             CIRCLE (mx(1), y1), 2, &HFFFFFF00 'marking intersect points yellow
  68.             CIRCLE (mx(1), y2), 2, &HFFFFFF00
  69.             CIRCLE (mx(1), y1), 4, &HFFFFFF00 'marking intersect points yellow
  70.             CIRCLE (mx(1), y2), 4, &HFFFFFF00
  71.  
  72.         END IF
  73.     ELSE
  74.         'OK the calculations!
  75.         'from inserting eq ofline into eq of circle where line intersects circle see reference
  76.         ' https://math.stackexchange.com/questions/228841/how-do-i-calculate-the-intersections-of-a-straight-line-and-a-circle
  77.         A = m ^ 2 + 1
  78.         B = 2 * (m * Y0 - m * q - p)
  79.         C = q ^ 2 - r ^ 2 + p ^ 2 - 2 * Y0 * q + Y0 ^ 2
  80.         D = B ^ 2 - 4 * A * C 'telling part of Quadratic formula = 0 then circle is tangent  or > 0 then 2 intersect points
  81.         IF D < 0 THEN ' no intersection
  82.             PRINT "m, y0 "; TS$(m); ", "; TS$(Y0)
  83.             PRINT "(p, q) "; TS$(p); ", "; TS$(q)
  84.             PRINT "A: "; TS$(A)
  85.             PRINT "B: "; TS$(B)
  86.             PRINT "C: "; TS$(C)
  87.             PRINT "D: "; TS$(D); " negative so no intersect."
  88.         ELSEIF D = 0 THEN ' one point tangent
  89.             x1 = (-B + SQR(D)) / (2 * A)
  90.             y1 = m * x1 + Y0
  91.             PRINT "Tangent Point Intersect (x1, y1) = "; TS$(x1); ", "; TS$(y1)
  92.             CIRCLE (x1, y1), 2, &HFFFFFF00 'yellow circle should be on line perprendicular to 3rd click point
  93.             CIRCLE (x1, y1), 4, &HFFFFFF00 'yellow circle should be on line perprendicular to 3rd click point
  94.         ELSE
  95.             '2 points
  96.             x1 = (-B + SQR(D)) / (2 * A): y1 = m * x1 + Y0
  97.             x2 = (-B - SQR(D)) / (2 * A): y2 = m * x2 + Y0
  98.             PRINT "2 Point intersect (x1, y1) = "; TS$(x1); ", "; TS$(y1); "  (x2, y2) = "; TS$(x2); ", "; TS$(y2)
  99.             CIRCLE (x1, y1), 2, &HFFFFFF00 'marking intersect points yellow
  100.             CIRCLE (x2, y2), 2, &HFFFFFF00
  101.             CIRCLE (x1, y1), 4, &HFFFFFF00 'marking intersect points yellow
  102.             CIRCLE (x2, y2), 4, &HFFFFFF00
  103.         END IF
  104.     END IF
  105.     _DISPLAY
  106.     INPUT "press enter to continue, any + enter to quit "; q$
  107.     IF LEN(q$) THEN SYSTEM
  108.     pi = 0 'point index
  109.  
  110. SUB slopeYintersect (X1, Y1, X2, Y2, slope, Yintercept) ' fix for when x1 = x2
  111.     slope = (Y2 - Y1) / (X2 - X1)
  112.     Yintercept = slope * (0 - X1) + Y1
  113.  
  114. FUNCTION TS$ (n)
  115.     TS$ = _TRIM$(STR$(n))

CircleIntersectLine.png

7
Chaotic Scattering: Gaspard-Rice system

Author: @_vince
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=78.0
Version: 2018
Tags: [geometry], [ray reflections]

Description:
https://en.wikipedia.org/wiki/Chaotic_scattering

Demo of the Gaspard-Rice system as described above.  Left-click to change location.


Source Code:
Code: QB64: [Select]
  1. DEFINT A-Z
  2. sw = 640
  3. sh = 480
  4.  
  5.  
  6. pi = 3.141593
  7.  
  8. SCREEN _NEWIMAGE(sw, sh, 12)
  9.  
  10. r = 150
  11. rr = 100
  12.  
  13. xx = sw / 2
  14. yy = sh / 2
  15.  
  16.     DO
  17.         mx = _MOUSEX
  18.         my = _MOUSEY
  19.         mb = _MOUSEBUTTON(1)
  20.  
  21.     LINE (0, 0)-(sw, sh), 0, BF
  22.     FOR b = 0 TO 2 * pi STEP 2 * pi / 3
  23.         CIRCLE (r * COS(b) + sw / 2, r * SIN(b) + sh / 2), rr
  24.     NEXT
  25.  
  26.     IF mb THEN
  27.         f = -1
  28.         DO WHILE mb
  29.             DO
  30.                 mb = _MOUSEBUTTON(1)
  31.             LOOP WHILE _MOUSEINPUT
  32.         LOOP
  33.         FOR b = 0 TO 2 * pi STEP 2 * pi / 3
  34.             x1 = r * COS(b) + sw / 2
  35.             y1 = r * SIN(b) + sh / 2
  36.             IF (mx - x1) ^ 2 + (my - y1) ^ 2 < rr * rr THEN f = 0
  37.         NEXT
  38.         IF f THEN
  39.             xx = mx
  40.             yy = my
  41.             f = -1
  42.         END IF
  43.     END IF
  44.  
  45.     x0 = xx
  46.     y0 = yy
  47.  
  48.     a = _ATAN2(my - yy, mx - xx)
  49.  
  50.     t = 0
  51.     DO
  52.         t = t + 1
  53.         x = t * COS(a) + x0
  54.         y = t * SIN(a) + y0
  55.         IF x < 0 OR x > sw OR y < 0 OR y > sh THEN EXIT DO
  56.         FOR b = 0 TO 2 * pi STEP 2 * pi / 3
  57.             x1 = r * COS(b) + sw / 2
  58.             y1 = r * SIN(b) + sh / 2
  59.             IF (x - x1) ^ 2 + (y - y1) ^ 2 < rr * rr THEN
  60.                 a1 = _ATAN2(y - y1, x - x1)
  61.                 a2 = 2 * a1 - a - pi
  62.  
  63.                 LINE (x0, y0)-(x, y), 14
  64.  
  65.                 x0 = x
  66.                 y0 = y
  67.                 a = a2
  68.                 t = 0
  69.                 EXIT FOR
  70.             END IF
  71.         NEXT
  72.     LOOP
  73.  
  74.     LINE (x0, y0)-(x, y), 14
  75.  
  76.     _DISPLAY
  77.     _LIMIT 50
  78.  

ChaoticScattering.png

8
Utilities / Circle Intersecting Circle by STxAxTIC
« on: March 05, 2020, 11:06:44 pm »
Circle Intersecting Circle

Author: @bplus @STxAxTIC
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1973.0
Version: 2019
Tags: [2d], [geometry], [intersections]

Description:
Here we present two (equivalent) methods for calculating the intersection points between any two circles.

Source Code:
Code: QB64: [Select]
  1.  
  2. C1x = -100
  3. C1y = 50
  4. C2x = 100
  5. C2y = 100
  6. r1 = 150
  7. r2 = 100
  8.  
  9.         IF _MOUSEBUTTON(1) THEN
  10.             C2x = _MOUSEX - 320
  11.             C2y = 240 - _MOUSEY
  12.         END IF
  13.         IF _MOUSEBUTTON(2) THEN
  14.             C1x = _MOUSEX - 320
  15.             C1y = 240 - _MOUSEY
  16.         END IF
  17.     LOOP
  18.  
  19.     CLS
  20.     CIRCLE (320 + C1x, C1y * -1 + 240), r1, 8
  21.     CIRCLE (320 + C2x, C2y * -1 + 240), r2, 7
  22.  
  23.     ''' Toggle between the two functions here.
  24.     'CALL CircleIntersectCircle(C1x, C1y, r1, C2x, C2y, r2, i1x, i1y, i2x, i2y)
  25.     CALL CircleIntersectCircle2(C1x, C1y, r1, C2x, C2y, r2, i1x, i1y, i2x, i2y)
  26.     '''
  27.     LOCATE 1, 1: PRINT i1x, i1y, i2x, i2y
  28.  
  29.     IF (i1x OR i1y OR i2x OR i2y) THEN
  30.         CIRCLE (320 + i1x, i1y * -1 + 240), 3, 14
  31.         CIRCLE (320 + i2x, i2y * -1 + 240), 3, 15
  32.     END IF
  33.  
  34.     _DISPLAY
  35.     _LIMIT 30
  36.  
  37. SUB CircleIntersectCircle (c1x, c1y, r1, c2x, c2y, r2, i1x, i1y, i2x, i2y)
  38.     ' Returns i1x, i1y, i2x, i2y
  39.     i1x = 0: i1y = 0: i2x = 0: i2y = 0
  40.     Dx = c1x - c2x
  41.     Dy = c1y - c2y
  42.     D2 = Dx * Dx + Dy * Dy
  43.     IF (D2 ^ .5 < (r1 + r2)) THEN
  44.         F = (-D2 + r2 * r2 - r1 * r1) / (2 * r1)
  45.         a = Dx / F
  46.         b = Dy / F
  47.         g = a * a + b * b
  48.         IF (g > 1) THEN
  49.             h = SQR(g - 1)
  50.             i1x = c1x + r1 * (a + b * h) / g
  51.             i1y = c1y + r1 * (b - a * h) / g
  52.             i2x = c1x + r1 * (a - b * h) / g
  53.             i2y = c1y + r1 * (b + a * h) / g
  54.         END IF
  55.     END IF
  56.  
  57. SUB CircleIntersectCircle2 (c1x, c1y, r1, c2x, c2y, r2, i1x, i1y, i2x, i2y)
  58.     ' Returns i1x, i1y, i2x, i2y
  59.     d = ((c1x - c2x) ^ 2 + (c1y - c2y) ^ 2) ^ .5
  60.     alpha = _ACOS((r1 ^ 2 + d ^ 2 - r2 ^ 2) / (2 * r1 * d))
  61.     x1 = r1 * COS(alpha)
  62.     l = r1 * SIN(alpha)
  63.     angle = _ATAN2(c2y - c1y, c2x - c1x)
  64.     p3x = c1x + x1 * COS(angle)
  65.     p3y = c1y + x1 * SIN(angle)
  66.     i1x = p3x + l * COS(angle - _PI / 2)
  67.     i1y = p3y + l * SIN(angle - _PI / 2)
  68.     i2x = p3x + l * COS(angle + _PI / 2)
  69.     i2y = p3y + l * SIN(angle + _PI / 2)

CircleintersectCircle.png

9
Games / BadBox Revenge by TerryRitchie
« on: March 05, 2020, 08:56:36 pm »
BadBox Revenge

Author: @TerryRitchie
Source: www.qb64sourcecode.com
URL: https://www.qb64sourcecode.com/RitchiesCode.zip
Version: 2020
Tags: [2d], [game], [shooter]

Description:
An advanced version of BadBox showing how to do rotation and angular math (for QB64 class)

Source Code:
See download(s) below.

BadBoxRevenge.png

10
Games / BadBox by TerryRitchie
« on: March 05, 2020, 08:54:16 pm »
BadBox

Author: @TerryRitchie
Source: www.qb64sourcecode.com
URL: https://www.qb64sourcecode.com/RitchiesCode.zip
Version: 2020
Tags: [2d], [game], [box collision]

Description:
A simple game that shows off collision detection (for QB64 class)

Source Code:
See download(s) below.

BadBox.png

11
Interpreters / LISP Interpreter by qbguy
« on: March 04, 2020, 06:32:36 pm »
LISP Interpreter

Author: @qbguy
Source: qb64.org Forums
URL: https://www.qb64.org/forum/index.php?topic=676.0
Version: STxAxTIC mod 2014
Tags: [interpreter]

Description:
Any sufficiently complicated C or Fortran program contains an ad hoc, informally-specified, bug-ridden, slow implementation of half of Common Lisp. - Greenspun's tenth rule of programming

qbguy: Looks like QB64 still interprets 0-placed recursive functions incorrectly.  The version I posted triggers the recursion bug but it is easy to change the code so as not to use zero-place functions (e.g. make depth a parameter or add a dummy parameter).  STxAxTIC's modified version has this modification already but has the read code modified so it reads from a line of input so you can't split your expressions across lines.


Source Code:
Code: QB64: [Select]
  1. ' Original by qbguy.
  2. ' Edits by STxAxTIC (10/16/2014).
  3. ' Posted to qb64.org forums on 10-06-2018.
  4.  
  5. DECLARE FUNCTION hash (s$)
  6. DECLARE FUNCTION READOBJ (depth)
  7. DECLARE FUNCTION READTOKEN (depth)
  8. DECLARE FUNCTION STRTOATOM (s$)
  9. DECLARE FUNCTION CONS (car, cdr)
  10. DECLARE FUNCTION READLIST (depth)
  11. DECLARE FUNCTION ALLOC ()
  12. DECLARE SUB PRINTOBJ (id)
  13. DECLARE FUNCTION EVALOBJ (id, env)
  14. DECLARE FUNCTION apply (f, args)
  15. DECLARE FUNCTION lookup (anum, env)
  16. DECLARE FUNCTION lvals (id, env)
  17. DECLARE SUB defvar (var, vals, env)
  18. DECLARE SUB setvar (id, vals, env)
  19. DECLARE FUNCTION mkprimop (id)
  20. DECLARE FUNCTION collect(p)
  21. DECLARE SUB gc(root)
  22. DECLARE FUNCTION DoLISP$(TheStringIn$, envin)
  23.  
  24. ' Make these smaller to get it to work in QBASIC / QuickBASIC
  25. CONST msize = 16384 'size of memory -- arbitrary
  26. CONST hsize = 4096 'size of hash table -- should be power of 2
  27.  
  28. DIM SHARED bufpos AS INTEGER, state AS INTEGER
  29. DIM SHARED hptr
  30. DIM SHARED atom$(0 TO hsize - 1), heap(2 * msize - 1, 2)
  31. DIM SHARED mmin, nmin, gcnow
  32.  
  33. mmin = 1: nmin = msize
  34.  
  35. DIM SHARED TheInput$
  36. DIM SHARED TheOutput$
  37.  
  38. CONST TRUE = -1
  39. CONST FALSE = 0
  40. CONST TNIL = 0
  41. CONST TCONS = 2
  42. CONST TNUM = 3
  43. CONST TSYM = 4
  44. CONST TPROC = 5
  45. CONST TPPROC = 6
  46. CONST TOKNIL = 0
  47. CONST TOKERR = -1
  48. CONST TOKOPEN = -2
  49. CONST TOKCLOSE = -3
  50. CONST TOKQUOTE = -4
  51. CONST TOKDOT = -5
  52.  
  53. CONST PPLUS = 1
  54. CONST PMINUS = 2
  55. CONST PTIMES = 3
  56. CONST PCONS = 4
  57. CONST PCAR = 5
  58. CONST PCDR = 6
  59. CONST PEQUAL = 7
  60. CONST PNOT = 8
  61. CONST PEQ = 9
  62. CONST PSETCAR = 10
  63. CONST PSETCDR = 11
  64. CONST PAPPLY = 12
  65. CONST PLIST = 13
  66. CONST PREAD = 14
  67. CONST PLT = 15
  68. CONST PGT = 16
  69. CONST PGEQ = 17
  70. CONST PLEQ = 18
  71. CONST PNUMP = 20
  72. CONST PPROCP = 21
  73. CONST PSYMP = 22
  74. CONST PCONSP = 24
  75.  
  76. ''''''''''
  77.  
  78. hptr = mmin: bufpos = 1
  79. vars = TNIL
  80. vals = TNIL
  81. frame = CONS(vars, vals)
  82. env = CONS(frame, TNIL)
  83. CALL defvar(STRTOATOM("+"), mkprimop(PPLUS), env)
  84. CALL defvar(STRTOATOM("-"), mkprimop(PMINUS), env)
  85. CALL defvar(STRTOATOM("*"), mkprimop(PTIMES), env)
  86. 'CALL defvar(STRTOATOM("%"), mkprimop(PMOD), env)
  87. CALL defvar(STRTOATOM("CONS"), mkprimop(PCONS), env)
  88. CALL defvar(STRTOATOM("CAR"), mkprimop(PCAR), env)
  89. CALL defvar(STRTOATOM("CDR"), mkprimop(PCDR), env)
  90. CALL defvar(STRTOATOM("="), mkprimop(PEQUAL), env)
  91. CALL defvar(STRTOATOM("NOT"), mkprimop(PNOT), env)
  92. CALL defvar(STRTOATOM("EQ?"), mkprimop(PEQ), env)
  93. CALL defvar(STRTOATOM("EQV?"), mkprimop(PEQ), env)
  94. CALL defvar(STRTOATOM("T"), STRTOATOM("T"), env) ' true
  95. CALL defvar(STRTOATOM("SET-CAR!"), mkprimop(PSETCAR), env)
  96. CALL defvar(STRTOATOM("SET-CDR!"), mkprimop(PSETCDR), env)
  97. CALL defvar(STRTOATOM("APPLY"), mkprimop(PAPPLY), env)
  98. CALL defvar(STRTOATOM("LIST"), mkprimop(PLIST), env)
  99. CALL defvar(STRTOATOM("READ"), mkprimop(PREAD), env)
  100. CALL defvar(STRTOATOM("<"), mkprimop(PLT), env)
  101. CALL defvar(STRTOATOM(">"), mkprimop(PGT), env)
  102. CALL defvar(STRTOATOM(">="), mkprimop(PGEQ), env)
  103. CALL defvar(STRTOATOM("<="), mkprimop(LEQ), env)
  104. CALL defvar(STRTOATOM("SYMBOL?"), mkprimop(PSYMP), env)
  105. CALL defvar(STRTOATOM("NUMBER?"), mkprimop(PNUMP), env)
  106. CALL defvar(STRTOATOM("PROCEDURE?"), mkprimop(PPROCP), env)
  107. CALL defvar(STRTOATOM("PAIR?"), mkprimop(PCONSP), env)
  108.  
  109.     LINE INPUT ">"; q$
  110.     r$ = DoLISP$(q$, env)
  111.     PRINT r$: PRINT
  112.  
  113. ''''''''''
  114.  
  115. FUNCTION DoLISP$ (TheStringIn AS STRING, envin)
  116. TheInput$ = TheStringIn
  117. TheOutput$ = ""
  118. s = READOBJ(0)
  119.     CASE TOKCLOSE
  120.         ' Unmatched closed parenthesis.
  121.         TheOutput$ = TheOutput$ + "[Unmatched closed parenthesis.]"
  122.     CASE TOKDOT
  123.         'PRINT "Dot used outside list."
  124.         TheOutput$ = TheOutput$ + "[Dot used outside list.]"
  125.     CASE TOKERR
  126.         'PRINT "[Error]"
  127.         TheOutput$ = TheOutput$ + "[Error]"
  128.     CASE ELSE
  129.         CALL PRINTOBJ(EVALOBJ(s, envin))
  130. DoLISP$ = TheOutput$
  131.  
  132. 'DO
  133. '    s = READOBJ(0)
  134. '    SELECT CASE s
  135. '        CASE TOKCLOSE
  136. '            ' unmatched closed parenthesis
  137. '        CASE TOKDOT
  138. '            PRINT "dot used outside list"
  139. '        CASE TOKERR
  140. '            PRINT "[Error]"
  141. '        CASE ELSE
  142. '            CALL PRINTOBJ(EVALOBJ(s, env))
  143. '    END SELECT
  144. '    PRINT
  145. '    IF gcnow THEN CALL gc(env)
  146. 'LOOP
  147.  
  148. FUNCTION ALLOC
  149. ALLOC = hptr
  150. hptr = hptr + 1
  151. IF hptr > (mmin + 3 * (msize / 4)) THEN gcnow = -1
  152.  
  153. FUNCTION apply (id, args)
  154. IF heap(id, 0) = TPROC THEN
  155.     params = heap(id, 1)
  156.     body = heap(heap(id, 2), 1)
  157.     procenv = heap(heap(id, 2), 2)
  158.     env = CONS(CONS(params, args), procenv)
  159.     DO WHILE heap(body, 2)
  160.         t = heap(body, 1)
  161.         t = EVALOBJ(t, env) 'ignore result
  162.         body = heap(body, 2)
  163.     LOOP
  164.     t = heap(body, 1)
  165.     apply = EVALOBJ(t, env)
  166. ELSEIF heap(id, 0) = TPPROC THEN
  167.     SELECT CASE heap(id, 1)
  168.         CASE PPLUS
  169.             sum = 0
  170.             a = args
  171.             WHILE a
  172.                 sum = sum + heap(heap(a, 1), 1)
  173.                 a = heap(a, 2)
  174.             WEND
  175.             p = ALLOC
  176.             heap(p, 0) = TNUM
  177.             heap(p, 1) = sum
  178.             apply = p
  179.         CASE PTIMES
  180.             prod = 1
  181.             a = args
  182.             WHILE a
  183.                 prod = prod * heap(heap(a, 1), 1)
  184.                 a = heap(a, 2)
  185.             WEND
  186.             p = ALLOC
  187.             heap(p, 0) = TNUM
  188.             heap(p, 1) = prod
  189.             apply = p
  190.             'CASE PMOD
  191.             '    prod = 1
  192.             '    a = args
  193.             '    WHILE a
  194.             '        prod = prod MOD heap(heap(a, 1), 1)
  195.             '        a = heap(a, 2)
  196.             '    WEND
  197.             '    p = ALLOC
  198.             '    heap(p, 0) = TNUM
  199.             '    heap(p, 1) = prod
  200.             '    apply = p
  201.         CASE PCONS
  202.             apply = CONS(heap(args, 1), heap(heap(args, 2), 1))
  203.         CASE PCAR
  204.             apply = heap(heap(args, 1), 1)
  205.         CASE PCDR
  206.             apply = heap(heap(args, 1), 2)
  207.         CASE PEQUAL
  208.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  209.             f = heap(heap(args, 1), 1)
  210.             a = heap(args, 2)
  211.             DO WHILE a
  212.                 IF heap(heap(a, 1), 1) <> f THEN apply = TNIL: EXIT FUNCTION
  213.                 a = heap(a, 2)
  214.             LOOP
  215.             apply = STRTOATOM("T"): EXIT FUNCTION
  216.         CASE PNOT
  217.             IF heap(args, 1) THEN apply = TNIL ELSE apply = STRTOATOM("T")
  218.         CASE PEQ
  219.             arg1 = heap(args, 1)
  220.             arg2 = heap(heap(args, 2), 1)
  221.             IF heap(arg1, 0) <> heap(arg2, 0) THEN apply = TNIL: EXIT FUNCTION
  222.             SELECT CASE heap(arg1, 0)
  223.                 CASE TNUM, TPROC, TPPROC, TSYM
  224.                     IF heap(arg1, 1) = heap(arg2, 1) THEN apply = STRTOATOM("T")
  225.                 CASE TCONS, TNIL
  226.                     IF arg1 = arg2 THEN apply = STRTOATOM("T")
  227.             END SELECT
  228.         CASE PLT
  229.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  230.             f = heap(heap(args, 1), 1)
  231.             a = heap(args, 2)
  232.             DO WHILE a
  233.                 IF f < heap(heap(a, 1), 1) THEN
  234.                     f = heap(heap(a, 1), 1)
  235.                     a = heap(a, 2)
  236.                 ELSE
  237.                     apply = TNIL: EXIT FUNCTION
  238.                 END IF
  239.             LOOP
  240.             apply = STRTOATOM("T"): EXIT FUNCTION
  241.         CASE PGT
  242.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  243.             f = heap(heap(args, 1), 1)
  244.             a = heap(args, 2)
  245.             DO WHILE a
  246.                 IF f > heap(heap(a, 1), 1) THEN
  247.                     f = heap(heap(a, 1), 1)
  248.                     a = heap(a, 2)
  249.                 ELSE
  250.                     apply = TNIL: EXIT FUNCTION
  251.                 END IF
  252.             LOOP
  253.             apply = STRTOATOM("T"): EXIT FUNCTION
  254.         CASE PLEQ
  255.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  256.             f = heap(heap(args, 1), 1)
  257.             a = heap(args, 2)
  258.             DO WHILE a
  259.                 IF f <= heap(heap(a, 1), 1) THEN
  260.                     f = heap(heap(a, 1), 1)
  261.                     a = heap(a, 2)
  262.                 ELSE
  263.                     apply = TNIL: EXIT FUNCTION
  264.                 END IF
  265.             LOOP
  266.             apply = STRTOATOM("T"): EXIT FUNCTION
  267.         CASE PGEQ
  268.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  269.             f = heap(heap(args, 1), 1)
  270.             a = heap(args, 2)
  271.             DO WHILE a
  272.                 IF f >= heap(heap(a, 1), 1) THEN
  273.                     f = heap(heap(a, 1), 1)
  274.                     a = heap(a, 2)
  275.                 ELSE
  276.                     apply = TNIL: EXIT FUNCTION
  277.                 END IF
  278.             LOOP
  279.             apply = STRTOATOM("T"): EXIT FUNCTION
  280.         CASE PSETCAR
  281.             arg1 = heap(args, 1)
  282.             arg2 = heap(heap(args, 2), 1)
  283.             heap(arg1, 1) = arg2
  284.         CASE PSETCDR
  285.             arg1 = heap(args, 1)
  286.             arg2 = heap(heap(args, 2), 1)
  287.             heap(arg2, 2) = arg2
  288.         CASE PAPPLY
  289.             arg1 = heap(args, 1)
  290.             arg2 = heap(heap(args, 2), 1)
  291.             apply = apply(arg1, arg2)
  292.         CASE PLIST
  293.             apply = args
  294.         CASE PREAD
  295.             apply = READOBJ(0)
  296.         CASE PMINUS
  297.             arg1 = heap(heap(args, 1), 1)
  298.             rargs = heap(args, 2)
  299.             IF rargs THEN
  300.                 res = arg1
  301.                 WHILE rargs
  302.                     res = res - heap(heap(rargs, 1), 1)
  303.                     rargs = heap(rargs, 2)
  304.                 WEND
  305.                 p = ALLOC
  306.                 heap(p, 0) = TNUM: heap(p, 1) = res: apply = p
  307.             ELSE
  308.                 p = ALLOC: heap(p, 0) = TNUM: heap(p, 1) = -arg1
  309.                 apply = p
  310.             END IF
  311.         CASE PSYMP
  312.             targ1 = heap(heap(args, 1), 0)
  313.             IF targ1 = TSYM THEN apply = STRTOATOM("T")
  314.         CASE PNUMP
  315.             targ1 = heap(heap(args, 1), 0)
  316.             IF targ1 = TNUM THEN apply = STRTOATOM("T")
  317.         CASE PPROCP
  318.             targ1 = heap(heap(args, 1), 0)
  319.             IF targ1 = TPROC OR targ1 = TPPROC THEN apply = STRTOATOM("T")
  320.         CASE PCONSP
  321.             targ1 = heap(heap(args, 1), 0)
  322.             IF targ1 = TCONS THEN apply = STRTOATOM("T")
  323.     END SELECT
  324.     PRINT "Bad application -- not a function"
  325.     apply = TOKERR
  326.  
  327. FUNCTION CONS (car, cdr)
  328. p = ALLOC
  329. heap(p, 0) = TCONS
  330. heap(p, 1) = car
  331. heap(p, 2) = cdr
  332. CONS = p
  333.  
  334. SUB defvar (id, value, env)
  335. anum = heap(id, 1)
  336. frame = heap(env, 1)
  337. vars = heap(frame, 1)
  338. vals = heap(frame, 2)
  339. WHILE vars
  340.     IF heap(heap(vars, 1), 1) = anum THEN
  341.         heap(vals, 1) = value: EXIT SUB
  342.     END IF
  343.     vars = heap(vars, 2): vals = heap(vals, 2)
  344. vars = heap(frame, 1)
  345. vals = heap(frame, 2)
  346. heap(frame, 1) = CONS(id, vars)
  347. heap(frame, 2) = CONS(value, vals)
  348.  
  349. FUNCTION EVALOBJ (id, env)
  350. 1 SELECT CASE heap(id, 0)
  351.     CASE TNIL, TNUM ' self-evaluating
  352.         EVALOBJ = id
  353.     CASE TSYM
  354.         EVALOBJ = lookup(heap(id, 1), env)
  355.     CASE TCONS
  356.         o = heap(id, 1)
  357.         t = heap(o, 0)
  358.         IF t = TSYM THEN
  359.             a$ = atom$(heap(o, 1)) ' symbol name of car(id)
  360.             SELECT CASE a$
  361.                 CASE "QUOTE"
  362.                     EVALOBJ = heap(heap(id, 2), 1)
  363.                 CASE "SET!"
  364.                     vid = heap(heap(id, 2), 1) 'cadr
  365.                     aval = heap(heap(heap(id, 2), 2), 1) 'caddr
  366.                     CALL setvar(vid, EVALOBJ(aval, env), env)
  367.                 CASE "DEFINE"
  368.                     vid = heap(heap(id, 2), 1)
  369.                     aval = heap(heap(heap(id, 2), 2), 1)
  370.                     CALL setvar(vid, EVALOBJ(aval, env), env)
  371.                 CASE "IF"
  372.                     ' (if pred ic ia)
  373.                     pred = heap(heap(id, 2), 1) 'predicate = cadr
  374.                     ic = heap(heap(heap(id, 2), 2), 1) ' caddr
  375.                     ia = heap(heap(heap(heap(id, 2), 2), 2), 1) ' cadddr
  376.                     IF EVALOBJ(pred, env) THEN
  377.                         ' return EVALOBJ(ic,env)
  378.                         id = ic: GOTO 1
  379.                     ELSE
  380.                         ' return EVALOBJ(ia,env)
  381.                         id = ia: GOTO 1
  382.                     END IF
  383.                 CASE "LAMBDA"
  384.                     p = ALLOC
  385.                     heap(p, 0) = TPROC
  386.                     heap(p, 1) = heap(heap(id, 2), 1) ' cadr = args
  387.                     heap(p, 2) = CONS(heap(heap(id, 2), 2), env) 'caddr = body
  388.                     EVALOBJ = p
  389.                 CASE "BEGIN"
  390.                     seq = heap(id, 2)
  391.                     DO WHILE heap(seq, 2)
  392.                         t = heap(seq, 1)
  393.                         t = EVALOBJ(t, env) 'ignore result
  394.                         seq = heap(seq, 2)
  395.                     LOOP
  396.                     id = heap(seq, 1): GOTO 1
  397.                 CASE "AND"
  398.                     seq = heap(id, 2)
  399.                     DO WHILE heap(seq, 2)
  400.                         t = heap(seq, 1)
  401.                         t = EVALOBJ(t, env)
  402.                         IF t = 0 THEN EVALOBJ = 0: EXIT FUNCTION
  403.                         seq = heap(seq, 2)
  404.                     LOOP
  405.                     id = heap(seq, 1): GOTO 1
  406.                 CASE "OR"
  407.                     seq = heap(id, 2)
  408.                     DO WHILE heap(seq, 2)
  409.                         t = heap(seq, 1)
  410.                         t = EVALOBJ(t, env)
  411.                         IF t THEN EVALOBJ = t: EXIT FUNCTION
  412.                         seq = heap(seq, 2)
  413.                     LOOP
  414.                     id = heap(seq, 1): GOTO 1
  415.                 CASE "COND"
  416.                     clauses = heap(id, 2)
  417.                     WHILE clauses
  418.                         clause = heap(clauses, 1)
  419.                         pred = heap(clause, 1)
  420.                         IF EVALOBJ(pred, env) THEN
  421.                             seq = heap(clause, 2)
  422.                             DO WHILE heap(seq, 2)
  423.                                 t = heap(seq, 1)
  424.                                 t = EVALOBJ(t, env) 'ignore result
  425.                                 seq = heap(seq, 2)
  426.                             LOOP
  427.                             id = heap(seq, 1): GOTO 1
  428.                         END IF
  429.                         clauses = heap(clauses, 2)
  430.                     WEND
  431.                 CASE ELSE
  432.                     args = heap(id, 2)
  433.                     proc = EVALOBJ(o, env)
  434.                     EVALOBJ = apply(proc, lvals(args, env))
  435.             END SELECT
  436.         ELSE
  437.             args = heap(id, 2)
  438.             proc = EVALOBJ(o, env)
  439.             EVALOBJ = apply(proc, lvals(args, env))
  440.         END IF
  441.     CASE ELSE
  442.         PRINT "Unhandled expression type: "; a$
  443.         EVALOBJ = id
  444.  
  445. FUNCTION hash (s$)
  446. FOR i = 1 TO LEN(s$)
  447.     c = ASC(MID$(s$, i, 1))
  448.     h = (h * 33 + c) MOD hsize
  449. hash = h
  450.  
  451. FUNCTION lookup (anum, env)
  452. ' env is a list of (vars . vals) frames
  453. ' where: vars is a list of symbols
  454. '        vals is a list of their values
  455. e = env
  456.     frame = heap(e, 1) ' get the first frame
  457.  
  458.     vars = heap(frame, 1) ' vars is car
  459.  
  460.     vals = heap(frame, 2) ' vals is cdr
  461.  
  462.     WHILE vars ' while vars left to check
  463.         IF heap(heap(vars, 1), 1) = anum THEN 'atom number of car(vars) = anum
  464.             lookup = heap(vals, 1) ' car(vals)
  465.             EXIT FUNCTION
  466.         END IF
  467.         vars = heap(vars, 2) 'cdr(vars)
  468.         vals = heap(vals, 2) 'cdr(vals)
  469.     WEND
  470.     e = heap(e, 2) ' cdr(e)
  471. 'PRINT "Unbound variable: "; atom$(anum)
  472. TheOutput$ = TheOutput$ + "Unbound variable: " + atom$(anum)
  473. lookup = TOKERR
  474.  
  475. FUNCTION lvals (id, env)
  476. IF heap(id, 0) = TCONS THEN
  477.     car = heap(id, 1)
  478.     ecar = EVALOBJ(car, env)
  479.     head = CONS(ecar, 0)
  480.     l = heap(id, 2): prev = head
  481.     WHILE l
  482.         car = heap(l, 1)
  483.         ecar = EVALOBJ(car, env)
  484.         new = CONS(ecar, 0)
  485.         heap(prev, 2) = new
  486.         prev = new
  487.         l = heap(l, 2)
  488.     WEND
  489.     lvals = head
  490.     lvals = 0
  491.  
  492. FUNCTION mkprimop (id)
  493. p = ALLOC
  494. heap(p, 0) = TPPROC
  495. heap(p, 1) = id
  496. mkprimop = p
  497.  
  498. SUB PRINTOBJ (id)
  499.  
  500. IF id = TOKERR THEN PRINT "[Error]": EXIT SUB
  501. SELECT CASE heap(id, 0)
  502.     CASE TNIL
  503.         'PRINT "()";
  504.         TheOutput$ = TheOutput$ + "()"
  505.     CASE TCONS
  506.         'PRINT "(";
  507.         TheOutput$ = TheOutput$ + "("
  508.         printlist:
  509.         CALL PRINTOBJ(heap(id, 1))
  510.         'PRINT " ";
  511.         TheOutput$ = TheOutput$ + " "
  512.         cdr = heap(id, 2)
  513.         IF heap(cdr, 0) = TCONS THEN id = cdr: GOTO printlist
  514.         IF heap(cdr, 0) = TNIL THEN
  515.             'PRINT ")";
  516.             TheOutput$ = TheOutput$ + ")"
  517.         ELSE
  518.             'PRINT ".";
  519.             TheOutput$ = TheOutput$ + "."
  520.             CALL PRINTOBJ(cdr)
  521.             'PRINT ")";
  522.             TheOutput$ = TheOutput$ + ")"
  523.         END IF
  524.     CASE TNUM
  525.         'PRINT heap(id, 1);
  526.         TheOutput$ = TheOutput$ + STR$(heap(id, 1))
  527.     CASE TSYM
  528.         'PRINT atom$(heap(id, 1));
  529.         TheOutput$ = TheOutput$ + atom$(heap(id, 1))
  530.     CASE TPROC, TPPROC
  531.         'PRINT "[Procedure]"
  532.         TheOutput$ = TheOutput$ + "[Procedure]"
  533.  
  534. FUNCTION READLIST (depth)
  535. SH = READOBJ(depth)
  536.     CASE TOKERR
  537.         READLIST = TOKERR
  538.     CASE TOKCLOSE
  539.         READLIST = 0
  540.     CASE TOKDOT
  541.         SH = READOBJ(depth)
  542.         SELECT CASE SH
  543.             CASE TOKERR, TOKDOT, TOKCLOSE
  544.                 READLIST = TOKERR
  545.             CASE ELSE
  546.                 ST = READLIST(depth)
  547.                 IF ST THEN READLIST = TOKERR ELSE READLIST = SH
  548.         END SELECT
  549.     CASE ELSE
  550.         ST = READLIST(depth)
  551.         IF ST = TOKERR THEN READLIST = TOKERR ELSE READLIST = CONS(SH, ST)
  552.  
  553. FUNCTION READOBJ (depth)
  554. tok = READTOKEN(depth)
  555.     CASE TOKOPEN
  556.         s = READLIST(depth + 1)
  557.         READOBJ = s
  558.     CASE TOKQUOTE
  559.         tok = READOBJ(depth + 1)
  560.         SELECT CASE tok
  561.             CASE TOKCLOSE
  562.                 PRINT "warning: quote before close parenthesis"
  563.                 READOBJ = tok
  564.             CASE TOKDOT
  565.                 PRINT "warning: quote before dot"
  566.                 READOBJ = tok
  567.             CASE ELSE
  568.                 s = CONS(STRTOATOM("QUOTE"), CONS(tok, 0))
  569.                 READOBJ = s
  570.         END SELECT
  571.     CASE ELSE
  572.         READOBJ = tok
  573.  
  574. FUNCTION READTOKEN (depth)
  575.  
  576. start1: bufend = LEN(buf)
  577. WHILE bufpos < bufend AND INSTR(" " + CHR$(9), MID$(buf, bufpos, 1))
  578.     bufpos = bufpos + 1
  579. c$ = MID$(buf, bufpos, 1)
  580. IF INSTR(":;", c$) THEN
  581.     IF c$ = ":" THEN
  582.         bufpos = bufpos + 1
  583.         IF bufpos <= bufend THEN
  584.             SELECT CASE MID$(buf, bufpos, 1)
  585.                 CASE "q", "Q" ' quit
  586.                     SYSTEM
  587.                 CASE "g", "G" ' garbage collect now
  588.                     gcnow = -1
  589.                 CASE ELSE
  590.                     READTOKEN = TOKERR
  591.                     EXIT FUNCTION
  592.             END SELECT
  593.         END IF
  594.     END IF
  595.     bufpos = bufend + 1
  596. IF bufpos > bufend THEN
  597.     'IF depth = 0 THEN PRINT "]=> ";
  598.     'LINE INPUT buf
  599.     buf = TheInput$
  600.     bufend = LEN(buf)
  601.     bufpos = 1
  602.     GOTO start1
  603.     CASE "("
  604.         bufpos = bufpos + 1
  605.         READTOKEN = TOKOPEN
  606.     CASE ")"
  607.         bufpos = bufpos + 1
  608.         READTOKEN = TOKCLOSE
  609.     CASE "'"
  610.         bufpos = bufpos + 1
  611.         READTOKEN = TOKQUOTE
  612.     CASE "."
  613.         bufpos = bufpos + 1
  614.         READTOKEN = TOKDOT
  615.     CASE ELSE
  616.         strbeg = bufpos
  617.         bufpos = bufpos + 1
  618.         DO WHILE bufpos <= bufend
  619.             c$ = MID$(buf, bufpos, 1)
  620.             IF c$ = " " OR c$ = "." OR c$ = "(" OR c$ = ")" THEN EXIT DO
  621.             bufpos = bufpos + 1
  622.         LOOP
  623.         READTOKEN = STRTOATOM(MID$(buf, strbeg, bufpos - strbeg))
  624.  
  625. SUB setvar (id, value, env)
  626. anum = heap(id, 1)
  627. e = env
  628.     frame = heap(e, 1)
  629.     vars = heap(frame, 1)
  630.     vals = heap(frame, 2)
  631.     WHILE vars
  632.         IF heap(heap(vars, 1), 1) = anum THEN
  633.             heap(vals, 1) = value: EXIT SUB
  634.         END IF
  635.         vars = heap(vars, 2): vals = heap(vals, 2)
  636.     WEND
  637.     e = heap(e, 2)
  638. CALL defvar(id, value, env)
  639.  
  640. FUNCTION STRTOATOM (s$)
  641. l = LEN(s$)
  642. c$ = LEFT$(s$, 1)
  643. IF (c$ = "-" AND l >= 2) OR (c$ >= "0" AND c$ <= "9") THEN
  644.     v = 0
  645.     IF c$ = "-" THEN neg = 1: idx = 2 ELSE neg = 0: idx = 1
  646.     FOR idx = idx TO l
  647.         c$ = MID$(s$, idx, 1)
  648.         IF (c$ >= "0" AND c$ <= "9") THEN
  649.             v = v * 10 + (ASC(c$) - ASC("0"))
  650.         ELSE
  651.             EXIT FOR
  652.         END IF
  653.     NEXT
  654.     IF idx = l + 1 THEN
  655.         IF neg THEN v = -v
  656.         p = ALLOC
  657.         heap(p, 0) = TNUM
  658.         heap(p, 1) = v
  659.         STRTOATOM = p: EXIT FUNCTION
  660.     END IF
  661. IF UCASE$(s$) = "NIL" THEN STRTOATOM = TOKNIL: EXIT FUNCTION
  662.  
  663. i = hash(UCASE$(s$))
  664. FOR count = 1 TO hsize
  665.     IF atom$(i) = UCASE$(s$) THEN
  666.         found = TRUE: EXIT FOR
  667.     ELSEIF atom$(i) = "" THEN
  668.         atom$(i) = UCASE$(s$)
  669.         found = TRUE
  670.         EXIT FOR
  671.     ELSE
  672.         i = (i + count) MOD hsize
  673.     END IF
  674. IF NOT found THEN PRINT "Symbol table full!"
  675. p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i
  676. STRTOATOM = p
  677.  
  678. SUB gc (root)
  679. hptr = nmin
  680. root = collect(root)
  681. SWAP mmin, nmin
  682. SWAP mmax, nmax
  683. gcnow = 0
  684.  
  685. FUNCTION collect (p)
  686.  
  687. SELECT CASE heap(p, 0)
  688.  
  689.     CASE -1
  690.         collect = heap(p, 1)
  691.  
  692.     CASE TCONS, TPROC
  693.  
  694.         ' address of new copy
  695.         x = ALLOC
  696.  
  697.         ' car, cdr
  698.         a = heap(p, 1)
  699.         d = heap(p, 2)
  700.  
  701.         ' replace with forwarding address
  702.         heap(p, 0) = -1
  703.         heap(p, 1) = x
  704.  
  705.         ' copy
  706.         heap(x, 0) = heap(p, 0)
  707.         heap(x, 1) = collect(a)
  708.         heap(x, 2) = collect(d)
  709.         collect = x
  710.  
  711.     CASE TNIL
  712.         collect = 0
  713.  
  714.     CASE ELSE
  715.         x = ALLOC
  716.  
  717.         ' copy the entire structure
  718.         FOR i = 0 TO 2
  719.             heap(x, i) = heap(p, i)
  720.         NEXT
  721.  
  722.         ' write forwarding address
  723.         heap(p, 0) = -1
  724.         heap(p, 1) = x
  725.         collect = x
  726.  

Run-time input sample:
Code: [Select]
(+ 2 2)
(apply + '(1 2 3))
(+ 1 -3 2 5)
(define generator (lambda (x) (lambda (y) (IF y (generator y) x))))
(define pocket (generator 8))
(pocket nil)
(define pocktwo (pocket 10))
(pocktwo '())
(define fact (lambda (x) (IF (= x 0) 1 (* x (fact (+ x -1))))))
(fact 5)
(fact 7)
(DEFINE MAP (LAMBDA (F X) (IF X (CONS (F (CAR X)) (MAP F (CDR X))))))
(MAP (LAMBDA (X) (* X 2)) '(1 2 3 4 5 6 7 ))

LISP ss.png

12
Games / Stereospace 2 by Craz1000
« on: March 01, 2020, 04:05:46 pm »
Stereospace 2

Author: @Craz1000
Source:  http://craz1000.net
URL: https://www.qb64.org/forum/index.php?topic=2254.0
Version: 2020-10-05 update version 1.4 fixed score server
Tags: [2d], [game], [side-scroller]

Description:
Completed Space shooter game.


Stereospace2info.jpg

stereospace2.png

13
QB64 Discussion / Re: Samples Gallery
« on: March 01, 2020, 03:44:31 pm »
You both (Querkey and bplus) have full-blown power over the main boards and sub-boards. (Subordinates? lol) Anyway.

And yes Terry - let's showcase your effort. You've been a force of nature around here. Just find whatever posts and either bump them or make new threads, its all good.

14
Games / Spaceship by Fellippe Heitor
« on: March 01, 2020, 03:40:12 pm »
Spaceship

Author: @FellippeHeitor
Source: github
URL: https://github.com/FellippeHeitor/Spaceship
Version: 2016
Tags: [2d], [game], [side-scroller]

Description:
Fun fact about this game is that is started as a demo to teach a guy how to use controllers with qb64
Then I thought, hey let me add a star field real quick
Next thing I know is it has 2k lines now and a full game engine :-)


See download(s) below, or follow this link: https://github.com/FellippeHeitor/Spaceship

spaceship.png

15
Interpreters / QB64 Interpreter by Fellippe Heitor
« on: March 01, 2020, 03:29:52 pm »
QB64 Interpreter

Author: @FellippeHeitor
Source: github
URL: https://github.com/FellippeHeitor/QB64-interpreter
Version: 4190184 on Dec 18, 2019
Tags: [interpreter]

Description:
An up-and-coming QB64 interpreter.
I'm cool with questions.


Source Code:
See download(s) below, or follow this link: https://github.com/FellippeHeitor/QB64-interpreter

basiccmdline.png

Pages: [1] 2 3