I've recently been playing around with various programs which communicate with each other via TCP/IP, I've decided that I needed some sort of simple protocol to make certain that the data I send and receive from computer to computer is correct and not corrupted. Here's the routine I've basically set up so far:
Code: (Select All)
DIM SHARED Host AS LONG
SCREEN _NEWIMAGE(800, 600, 32)
COLOR &HFFFFFFFF, &HFF000000
Host = _OPENHOST("TCP/IP:7990") ' this will be the host code
DO
Player = GetClient 'Not
IF Player THEN
PRINT "New Player connected"
'Do stuff
UserData$ = In$(Player)
'do stuff with the data the user sent
'and close the connection
CLOSE Player
Player = 0
END IF
_LIMIT 30
LOOP
FUNCTION GetClient
GetClient = _OPENCONNECTION(Host) ' receive any new connection
END FUNCTION
FUNCTION In$ (who)
DIM b AS _UNSIGNED _BYTE
'CHR$(2) = Start of Text
'CHR$(3) = End of Text
'CHR$(4) = End of Transmission (It's what we use to tell the client, "We give up! Closing connection!"
'CHR$(6) = Acknowledge
'CHR$(15) = Not Acknowledge
GET #who, , b 'just check for a single byte from each connection
IF b <> 2 THEN
'If we get something which isn't a CHR$(2) to start communication, send back a failure notice.
SendError who
EXIT FUNCTION 'Exit so we can move on to the next connection to check for that leading chr$(2)
END IF
'Only if that initial byte is CHR$(2), do we acknowledge receipt and await further messages.
SendConfirmation who 'we send ACKnowledgement back to tell the client we're ready for them to talk to us.
DO
count = count + 1
timeout## = ExtendedTimer + 5
DO
_LIMIT 100 'no need to check for incoming information more than 100 times a second!
GET #who, , a$
IF a$ <> "" THEN tempIn$ = tempIn$ + a$ 'tempIn$ should never be more than 105 bytes
ETX = INSTR(a$, CHR$(3)) ' chr$(3) is our ETX character (End of TeXt)
IF ETX THEN EXIT DO
IF ExtendedTimer > timeout## THEN 'If it takes over 5 seconds to send 100 bytes (or less) of info
SendError who ' something is wrong. Terminate the attempt, but be nice, and let
EXIT FUNCTION ' the other client know something went wrong, so they can try again,
END IF ' if they want to.
LOOP UNTIL LEN(tempIn$) > 105 'If we have over 105 bytes with our string, we didn't send the data properly.
IF LEN(tempIn$) > 105 THEN
SendError who 'send the client an error message
EXIT FUNCTION
END IF
tempIn$ = _TRIM$(LEFT$(tempIn$, ETX - 1)) 'strip off the ETX character and check to make certain data is valid.
c$ = RIGHT$(tempIn$, 4) 'these 4 bytes are the checksum
CheckSum = CVL(c$) 'Check to make certain the data apprears valid.
FOR i = 1 TO LEN(l$): Check = Check + ASC(l$, i): NEXT
IF CheckSum <> Check THEN ' Our data is not what we expected. Part may be lost, or corrupted.
SendError who
EXIT FUNCTION
ELSE
SendConfirmation who
EXIT DO
END IF
LOOP UNTIL count = 5
'If we get bad data 5 times in a row, something is wrong. We're just going to close the connection.
IF count = 5 THEN
SendError who
EXIT FUNCTION
END IF
'and if we're down this far, our data has been recieved, verified, and is now good to use.
In$ = LEFT$(tempIn$, 4) 'left part of the string is the data the user is sending us
END FUNCTION
SUB SendError (who)
DIM b AS _UNSIGNED _BYTE
b = 4
PUT #who, , b
END SUB
SUB SendConfirmation (who)
DIM b AS _UNSIGNED _BYTE
b = 6
PUT #who, , b
END SUB
FUNCTION ExtendedTimer##
DIM m AS INTEGER, d AS INTEGER, y AS INTEGER
DIM s AS _FLOAT, day AS STRING
day = DATE$
m = VAL(LEFT$(day, 2))
d = VAL(MID$(day, 4, 2))
y = VAL(RIGHT$(day, 4)) - 1970
SELECT CASE m 'Add the number of days for each previous month passed
CASE 2: d = d + 31
CASE 3: d = d + 59
CASE 4: d = d + 90
CASE 5: d = d + 120
CASE 6: d = d + 151
CASE 7: d = d + 181
CASE 8: d = d + 212
CASE 9: d = d + 243
CASE 10: d = d + 273
CASE 11: d = d + 304
CASE 12: d = d + 334
END SELECT
IF (y MOD 4) = 2 AND m > 2 THEN d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
ExtendedTimer## = (s + TIMER)
END FUNCTION
Now this isn't going to work to send binary files, as I'm using some of the ASCII characters as reserved command codes, but since this isn't meant to be a file transfer protocol, I don't think it should be a problem. My command codes are as follows: 'CHR$(2) = Start of Text
'CHR$(3) = End of Text
'CHR$(4) = End of Transmission (It's what we use to tell the client, "We give up! Closing connection!"
'CHR$(6) = Acknowledge
'CHR$(15) = Not Acknowledge
The idea the behind the process is this one:
First, we simply wait for a CHR$(2) character to come in, as a request from a client saying they want to send us data. If we get anything else before that, we send them an error message. All messages start with chr$(2), and when we get it, we send a confirmation back to the client so they know we're all set to receive their data (CHR$(6)).
At this point, they send us the data, which is limited to being 105 bytes or less. This 105 byte structure consists of up to 100 bytes of data, 4 bytes for a checksum of the data sent, and then the termination code. (CHR$(3))
Once we verify that everything is correct, we either send back a success, or failure signal, to the client. If we fail, they can try to resend the data, otherwise all is golden.
I tried to comment the process here so that it'd be easily understood by anyone who looks it over, but if anyone has any questions, just ask them. If there appears to be something wrong with my logic, feel free to tell me about that as well. I haven't actually tested this in a working program yet (my test game is still in development and hasn't gotten to the point where it's trying to talk back and forth to other games yet), but I don't see anything that looks wrong with it. Unless I just made a common typo, or other silly mistake, it should work as intended here...
Take a look at it. See if it looks like a process that will hold up to general usage to send plain text back and forth between computers. And, if you see something that I goofed on, or overlooked, kindly point it out to me. If all works as intended, this will end up going into a transfer library later for me, so I can just plug it into any project and use it to send and receive data between devices.
First and most important thing to keep in mind with these is: I'm not a public speaker, nor a YouTube Superstar. I'm not good with the capture software, I'm not working with a script, and things tend to meander along -- glitches and confusion and all -- without any sort of editing going on with the videos. They're all excessively long, and someone who works with these things could probably reduce them down to half the size if they edited out my rural nature -- but they are what they are.
First one is lower resolution than all the rest in an attempt to save bandwidth, but folks mentioned they couldn't make things out the best, so the ones after that are at a sharper resolution.
It'd be a weekend marathon to sit down and watch all these back to back, but once finished, I don't think anybody would have any issues using the _MEM commands anymore.
Like always -- if anyone has questions, comments, or thoughts, you can feel free to ask them here and I'll do my best to answer and respond to whatever concerns you guys might have.
Create your oh program in your favorite Word Processor, I am using Notepad++.
Drag and drop the file onto the compiled oh.exe to run it (old way).
oh Menu:
oh now displays the contents of a program on a scroller if get one off Command$.
All files selected from Load with be displayed on scroller with Menu on top line:
(in yellow and red) New, Edit, Load, Run, Quit ; click or press first letter of
menu item to select it. Edit or New should load up the file in your default .Txt
Editor from a Shell call.
Commands, variables, line labels are case insensitive.
Re: Comments
' at start of a line, formally tells oh to ignore the line, it's a comment.
You can probably write comments in at your own risk without the '
as long as they don't start with a command word or symbol or have = sign
after first word.
Re: oh color settings, in case you need to get back to them:
Ink 100;180;225
Paper 0;0;39
*** Preloaded Variables and their Values:
"MouseX" ' use the poll command to update x pix see demo ao 3/14
"MouseY" ' use the poll command to update y pix
"MouseL" ' use the poll command to update Left button down = -1 or 0
"MouseR" ' use the poll command to update Right button status
"Key" ' use the poll command to update Last non empty key pressed, not sure about this one
"MT" = "" ' constant, handy name for nut'n which you can compare to inps (Input String)
"XMAX" = "1024" screen pixel width, constant
"YMAX" = "672" screen pixel height, constant
"RMAX" = "42" screen print rows, constant
"CMAX" = "128" screen print columns, constant
"NL" = Chr$(13) + Chr$(10) for .txt file delimiter
(note: I say constant but these are variable not wise to change them though.)
*** Print commands which use ; to delimit variables inside text
. normal print and carriage return line feed use / one space after . or after ; to set spaces
; print and next print position is right where it is, dont forget to finish line with a . line
, tab built in columns
tab columnWidth;item;item;item;...
cpr row;textgoes here with plug-in variables ';here; and ;here;.
Center Print Row print a line of text.
clipout args1 - replace Clipboard contents from any variable or literal
clipadd args1 - Append tp Clipboard contents any variable or literal,
the command does the first NL$ = Chr$(13) + Chr$(10),
you must do manually any inside the stuff you are appending, if needed.
*** Input commands also ; to delimit prompt and variable
inps this is a sample prompt;var s on end signals string expected and will return mt for just enter keypress
inpn this is a sample number prompt;var n on end will turn an empty string entered to 0
*** Screen stuff now semi-colon delimited arguments to allow each argument to be evaluated:
loc row;col AKA Locate for print chars 8x16
at col;row Alternate that corresponds to graphics x, y but in char cells 8x16
tag pixX;pixY;text$ AKA _PrintString
cpr row;text Center Print atRow;text with variables;embedded;I think.
*** Screen Drawing now semi-colon delimited arguments to allow each argument to be evaluated:
ink r;g;b;a fore-color for printing or drawing
paper r;g;b;a back-color usually set at start
pix x;y AKA Pset(x, y)
line x1;y1;x2;y2 AKA Line(x1, y1)-(x2, y2)
box x1;y1;w;h AKA Line(x1, y1)-Step(x2, y2), ,B
fbox x1;y1;w;h AKA Line(x1, y1)-Step(x2, y2), ,BF
circ x1;y1;r AKA Circle (x1, y1), r
fcirc x1;y1;rr AKA For r = 0 To rr Step .25 : Circle (x, y), r : Next
ftri x1;y1;x2;y2;x3;y3 Special MapTriangle command for
*** Misc:
poll Updates preset mouse and key variables
cls AKA Cls
zzz AKA Sleep
beep AKA Beep this comes in handy for debugging
wait nSecs AKA _Delay
show TF AKA _Display, AutoDisplay Boolean: True = stops blinking, False = immediate draw/print
mouse TF Mouse Hide if False = 0, Show Mouse if True <> 0
set Astring;index;itemValue compare to A(i) = itemValue
also see var = get[astring,index] SFunction below
rndPt (arg = variableContainer) gets the next rndPt from a deck of all points on screen,
this helps distribute graphics "randomly" on screen, covers every point
then deck is reshuffled for next layer
rp = rndPt
x = rp mod xmax or as we like to say at oh, m[rp,xmax]
y = int(rp/ymax) or as we like to say at oh, int[d[rp,ymax]]
*** Boolean IF blocks
if BooleanExpression
ei BooleanExpression AKA ElseIf
el AKA Else
fi AKA End If
*** Loop structure only one unless count goto
[ - starts loop
] - ends loop
*** only ways out of loops are:
jmp BooleanExpression Jump! out of the current loop level the command is in.
exit usually from inner if block, exits current loop level
end stop run
goto labelName:
*** GoSub
gs labelName\ AKA GoSub (3/21 : changed to \ as line label marker)
rtn AKA Return
labelName\ for gs and goto (3/21 : changed to \ as line label marker)
*** File simplicity:
Save Astring;toFileName - command
AstringVar = load[fileName] - SFunction
files[] - AString list of the files in the current directory
*** SFunctions Syntax:
var = SFunction[a1, a2, a3,...] variables setting or reassigning
*** Booleans:
and[a1, a2, a3,... ] only returns -1 when all are <> 0
or[a1, a2, a3,... ] returns -1 if any one is <> 0
seq[a1, a2] does a string compare a1 = a2? -1 if true, 0 if not
eq[a1, a2] does a numeric compare a1 = a2? -1 if true, 0 if not
lt[a1, a2] less than a1<a2 -1 if true, 0 if not
lte[a1, a2] less than or equal a1<=a2 -1 if true, 0 if not
gt[a1, a2] greater than a1>a2 -1 if true, 0 if not
gte[a1, a2] greater than or equal a1>=a2 -1 if true, 0 if not
noteq[a1, a2] not equal a1<>a2 -1 if true, 0 if not
not[a1] if a1 = 0 then Not returns -1 else Not returns 0
*** Arithmetics:
a[a1, a2, a3,...] adds them all, a is for add
x[a1, a2, a3,...] multiplies all, x is for mult.
s[a1, a2] a1 - a2 s is for subtract
d[a1, a2] a1 / a2 if a2 <> 0 d is for divide
m[a1, a2] a1 mod a2 m is for mod AKA the remainder
p[a1, a2] a1 ^ a2 p is for power
*** Extended Arithmetics extended math so extended the names ;-))
add[a1,a2]
subtract[a1,a2] - should this be subtract or subtr? I don't like sub
mult[a1,a2] - I am sure this is OK for multiply
divide[a1,a2] - handles approx 100 decimal places (got to set a limit or it'd go on forever!),
the 3 binary's above are arbitrary.
inverse[PosInteger,NumberOfDecimals] - for custom designed division when 100 decimals wont do.
sqrroot[a1] - working independently from Mr$ Function like inverse.
(The extended math had 14 Routines, MR$ is controller of the Big 4 and stands for Math Regulator.)
*** Maths misc:
int[a1] converts to Integer, remove floating point decimal end if any
sqr[a1] returns square root if a1 is positive or 0
log[a1] QB64's Log, natural logarithm, see wiki Log to convert to Log(base 10)
exp[a1] QB64's Exp, Exp(1) = e
rnd[a1] a1 is multiplier of Rnd (0 to almost 1) * a1
abs[a1] Absolute value of a1
*** Trigs (Radian angle units)
sin[a1] a1 angle in radians, returns unique ratio
cos[a1] a1 angle in radians, returns unique ratio
tan[a1] a1 angle in radians, returns unique ratio
asin[a1] a1 is ratio, returns angle in radian units
acos[a1] a1 is ratio, returns angle in radian units
atan[a1] a1 is ratio, returns angle in radian units
rad[a1] a1 is usually an angle in degrees needing to be changed to radian units
deg[a1] a1 is usually an angle in radians needing to be converted to degree units
pi[a1] a1 is a multiplier or fraction of Pi
atan2[a1 (=deltaY's) , a2 (=deltaX's) ] SFunction with 2 args, definitely a plus!
note: delta usu. means difference
Find the angle of point 1 (x1,y1) from point 2 (x2, y2) )
Basic: var = _atan2(y1-y2,x1-x2) or oh: var = atan2[s[y1,y2],s[x1,x2]]
( You can figure the rest of the Trig Functions from these. )
join[delimiter$, a2, a3,...] like the above but links the with delimiter,
for comma or space separated items or Chr$(10) line separators
Allot of string functions have counterparts joins counterpart is:
split[a1, a2] a1 is string to split, a2 is the delimiter, splits usually go into arrays
for oh we are using Astrings, strings that can be indexed to retrieve items using the "get" function.
Another way to build giant strings from building block is:
cop[a1, a2] better than String$ command because it makes a1 concatenated copies of string a2
rejoin[a1, a2] will take the special Astring, a1, formed from split or cop maybe bnd and split
and rejoin using the the delimiters given as a2. Say you have processed an Astring of data and
wish to save it in a file as comma separated or as line by line.
*** String slices:
mid1[a1, a2] AKA Mid$(a1, a2, 1) a 1 char return in a1 at a2
mid2[a1, a2] AKA standard Mid$(a1, a2) 2 argument return remainder of a1 starting at a2
mid3[a1, a2, a3] AKA standard 3 argument MID$
left[a1, num of chars] AKA Left$
right[a1, num of chars] AKA Right$
head[a1, a2] from a1 find a2 and take the part that comes before a2
tail[a1, a2] from a1 find a2 (end) and take the remainder of string from there.
*** String finds:
in2[a1, a2] position of first a2 found in a1
in3[a1, a2, a3] starting at a1, find and return a3 position in a2
*** Chars:
asc[a1] returns ascii value of char, space = 32, enter = 13, tab = 9, dbl quote = 34, hyphen = 45
chr[a1] returns char of ascii number chr(65) = A, chr(48) = 0
*** Trimming spaces:
rtr[a1] removes spaces from right
ltr[a1] removes spaces from left
trim[a1] removes spaces left and right
*** Shouting, whispering, modifying:
cap[a1] a1 in all capitals
low[a1] a1 all lower case
replace[source$,replace$,new$] - replaces a string with new$ wherever found in source$
*** Astrings: like arrays, these are strings you can "get" an item value by index #
Set Astring;index;itemToAddOrReassign - this is a command as opposed to an SFunction
so sets counterpart is get:
get[a1, a2] from Astring, a1, get the item at index, a2. Compare to var = A(i), var = get[astring, index]
nItems[Astring] number of Items in the Astring (counts delimiters and adds 1)
*** Now for some easy string functions:
len[a1] returns the length in chars of a1
spc[a1] returns a1 block of spaces
date[] no argument Date$
time[] no argument Time$
clip[] no argument get contents of _ClipBoard
timer[] no argument still need [] this the number of secs since midnight, 3 decimals at least.
*** Special Order String Functions:
ASSORT[a1] ascending string sort of astring, a1
DSSORT[a1] descending string sort of astring, a1
ANSORT[a1] ascending numeric sort of astring, a1
DNSORT[a1] descending numeric sort of astring, a1
Fval[a1] will attempt to evaluate a string or numeric expression of functions and literals.
*** File simplicity:
Save Astring;toFileName
AstringVar = load[fileName]
files[] - AString list of the files in the current directory
*** 2021-03-09 The "Screen" commands are now ; delimited to allow each argument to be evaluated.
Commands effected: loc at tag ink pix line box fbox circ fcirc ftri wait show paper
All demos effected have been updated.
New command: cpr for centering print on a row: cpr row;my text is this with a variable ;here; to plug in.
See: Test ac Fval$ Tester.txt, demo as this has been completely rewritten for cpr and first
test of using Fval$ to check arguments to commands.
A Splash screen for Oh?
*** 2021-03-10 Added 300 plus lines for File Dialog & Company including a very nice array displayer for showing the
loaded programs, maybe I could do a help? No that is better in tabbed Notepad++
Internal Splash is gone and the other internal test programs, net effect 1300 LOC including the start
of oh's menu system
direntry.h has been added to the zip package, please copy | paste into your QB64 folder for cross platform
directory and files access if you dont have a copy there already. This allows the File Dialog part of oh to
work correctly.
*** 2021-03-14
Dumped checking the _ClipBoard for a program now with File Dialog and all.
Tidied up oh's menu a tiny bit.
Check cpr handling of embedded variables and or SF[]'s, OK that is fixed up but not sure I want to
do that for the other print commands? Oh yes!!! I do want that! (Done)
Note: it you call edit without a file name you will wind up on the command line, just type exit.
Add Command:
Save Astring;Filename
Reminder: Astring is my term for a string with indexed variable length string items.
Save will store each item as a line in given filename.
Add SFunction:
Astring = Load[filename]
So that you can load a file into an Astring for indexed access to lines.
Consolidate Set and RndPt (even though RndPt takes no arguments it assigns a var)
commands with all the other ; delimited commands that do calculations. So now,
you don't have to have middleman variables in the commands, you can calc directly
in the command.
Add preloaded Mouse variables:
MouseX, MouseY, MouseL, MouseR
Locate (x, y) mouse in pix and Boolean Left or Right Button Down
Add preloaded variable:
Key
For keypress detection.
New Poll command to update all those preloaded variables with mouse and Key status.
Left$ and Right$ var = Right[a1$, val(a2$)
Ubound of Astring amount = nItems[AString]
*** 2021-03-16
Added: string math for extended arithmetics in SFunctions
add[a1,a2]
subtract[a1,a2]
mult[a1,a2]
divide[a1,a2]
(Divide: numerator/denominator, is calc'd by multiplying numerator by inverse of denominator).
(So the inverse is calculated to 100 Decimal Places, but sometimes 100 decimal places wont do
so inverse[posInteger,NumberOfDecimals] is added to do custom "division" by controlling the
decimals in inverse and to be then multiplied by numerator in a hand made division calculation.)
Added command:
clipout a1 + whatever argument 1 is holding: literal, variable value substitution
or expression of SFunctions replaces contents of Clipboard
Added command:
clipadd a1 appends to, instead of replaces, Clipboard data.
Added SFunction clip[] no argument SFunction, you still need the brackets.
This puts the contents of the contents of the Clipboard into the spec'd var.
eg var = clip[]
*** 2021-03-17
Basically just a few fixes and tweaks to get Donut.txt to work. Fixed the file line count
with a different load of a file. Fixed bug from reading the Len[] of a file, thrown off by
the file containing []'s!!! So a new SafeBS$ Function filter/converter created that
converts [] to {}. Needed to fix the Ink, Paper and color restoring after Run.
*** 2021-03-19
For Mouse Action Shooter - Target Practice (Graphics Game #2 attempt)
3/18 added mouse TF - command with 1 argument. True to Show Mouse, False to Hide Mouse
3/18 added abs[arg1] - SFunction with 1 argument. Kind of surprised how much I use ABS.
3/18 added timer[] - SFunction no argument, still need brackets.
3/18 added atan2[a1 (=deltaY's) , a2 (=deltaX's) ] SFunction with 2 args, definitely a plus!
Find the angle of point 1 (x1,y1) from point 2 (x2, y2)
Basic: var = _atan2(y1-y2,x1-x2) or oh: var = atan2[s[y1,y2],s[x1,x2]]
3/19 added beep (command) no args, main reason: to help debug.
*** 2021-03-22
3/20 added inverse[PosInteger,NumberOfDecimals] for custom division or control of decimals.
This is = 1/PosNumber to a set amount of decimals.
3/21 added files[] - no argument SFunction that loads the files of current directory into an AString.
3/21 added replace[stringSource,stringToReplace,StringToRplaceWith] - 3 arguments SFunction.
3/21 fix? load[] renders [ brackets impotent by swapping them with { brackets
save Astring;FileName sort of needs to reverse that by replacing { back to [
This is messy, in future something else may be a better solution.
3/21 Line labels now end with \ instead of colon. This is to be consistent to oh rule, no shifts.
3/21 Added another preloaded variable nl (Next Line) for file line delimiter.
Vnames$(11) = "NL": Vvalues$(10) = Chr$(13) + Chr$(10)
3/21 Gutted out opening code and rewrote the code to display files on a scroller when have a
filename and existing file. Now the menu runs across top line in yellow and red and can
click menu item or key press first letter for New, Edit, Load, Run, or Quit.
Much better if I do say so myself :) This completes my goals for this revision.
*** 2021-03-27
3/23 Fix file display scroller to accept PgUp, PgDn, Home, End Keypresses.
Also run file lines through filter JIT to replace tabs with 4 spaces and other
chars < 32 with *. This enables the display of 39 lines on 39 lines without screen
scrolling and menu line lost.
3/23 NL fixed and working as expected in: Test oh replace and nl.txt file.
3/23 Adding SHARED Lists: CmdList$ and FunList$ for Function OK$ a line Syntax checker function
that will return nothing (OK) if the line is fine, or what it found wrong with proposed
program line. Inventory: 40 commands (fix 4 more), 74 SFunctions
3/26 Added 3 more procedures for Syntax checking and immediately learned I missed 4 commands in
command list. The only line it caught after that was an title line without a formal comment.
I started editing Particle Fountain (it is hopelessly S L O W) and the syntax checker caught
a missing argument in an Or line when I mistakenly typed a } instead of a regular ] bracket.
Good, it catches at least something. So now lines start with comments, commands, variables
or line labels\ (\ ends a line label now).
3/27 Fixed - Mouse Action Shooter - the first bullet fired was always nothing?? and yet 10 points
is deducted from the score as it should be. Show me the bullet! I just initialized all the
bullets properties instead of only the bLive AStrings (arrays).
3/27 Fixed. After editing a file, you have to change directory and change back to get the new
file loaded with the changes. I now do that automatically in code after an Edit.
*** 2021-03-27A
3/27A Syntax checking had a little sloppy handling of closing ] assuming it was at end of line
instead of checking if one was actually there to match opening [. I found 4
working programs that were missing a final bracket at the end. I also found a program
that used [] instead of parenthesis and it was flagged for unknown SFunction. So that part
of syntax checking is also fixed, you will be flagged for unrecognized functions.
So I went through all working programs and they now fly through syntax checking right into
a successful run.
*** 2021-06-03 fix divide$
6/03 Fix the divide$ Function so that, Test oh High Precision Square Root.txt, file program works.
Also found the clipout and clipadd help in, oh Cheat Sheet.txt in error and fixed (no square
brackets to enclose the argument).
*** 2021-06-15 String Math update
6/15 A number of fixes and improvements to the String Math package including new sqrroot[number]
Function. Unfortunately with the new fixes the inverse of STx number takes a bit longer than
it did, it's a wonder it was getting correct results originally. When testing all the
programs I noticed the nl "constant" I had forgotten all about. This is doing double spaced
lines because it is Chr$(13)+Chr$(10) probably should be one or other, not both together.
Since last update we created new programs:
Aurels Henon code, Bresenham Circle Fill, First 100 digit Fibonacci, Sqr Root estimating.
A version of the last program became part of the String Math package update!
KEYS48 is a simple virtual piano (with 48 playable keys/notes) that you can play, record & save little songs with. Use the mouse to click on and play the notes. There's a menu (press M) that lists available commands. Saved songs (.K48 files) have a very small size thanks to QB64's _DEFLATE command.
There are a few pre-recorded songs included that you can load and play. When you start the program, press "L" to load a sample song, then type in DAV or SAMPLE or WALTZ to load & hear those songs. Those are examples of what you can record with Keys48.
This was made mostly for coding fun and not intended to be a serious instrument. Hope you will have fun with it too.
As you guys might know (if you don't, what the heck have you been doing -- hiding your head under a rock somewhere??), I've transitioned into a writer/novelist now that I've more or less officially retired here at the farm. October to January still keeps me busy with farm life, but otherwise I've got the rest of the year free to indulge my hobbies however I want.
For ages, I've been promising, "Some day, I'm going to sit down and end up writing up some sort of overly complex and wordy manual for QB64 that everyone can laugh at and nobody will probably ever use!"
Well, I just so happen to be snowed in -- and have been snowed in for the last few weeks -- and my boredom and restlessness has now gotten to the point where I finally decided to sit down and start on this little project: The QB64 Bible.
For now, all I've got is basically a write up about SCREEN 0 -- (and it's only about 14 pages long) -- but I hope it shows the style and format I'm shooting for here, and the information which I want to try and gather up into one easy to find and reference area.
Feel free to download it. Study it. Point out anything that seems unclear or imprecise, or that you just don't like, and offer any ideas of what you guys think should go into this little project. I'm just starting on this, but if all works out, I can probably churn out a few hundred pages of nonsense by the end of the month (provided I stick with this project exclusively during that time), so at that point it might actually have enough information in it to become something that somebody, somewhere, might want to make use of sometime in the future.
Just remember: This is a work in progress and is subject to any and all revisions, edits, changes, additions, and deletions -- at my whim and whimsey -- for the foreseeable future.
UPDATE: There's a little more in there now than just SCREEN 0 stuff. The above was a copy/paste from the first page of the old topic from the past forums which we had, and I'd already posted several additions and updates to the work from then till when everything was shut down.
Just checked this in Keybone's QB64 - Lite for Linux, it's been awhile since I've seen this.
Code: (Select All)
Option _Explicit
_Title "Spiral Colored Balls" 'B+ 2019-10-29 mod from
' 2019-10-29 mod be able to draw these balls anywhere
' Rotate colors on a sphere.txt for JB v2.0 bplus 2018-04-16
' from (extremely simplified) Double spiral.bas SmallBASIC 0.12.8 [B+=MGA] 2017-03-28
Const xmax = 1200, ymax = 700, pi = _Pi, nBalls = 10, ww = 3.14159 / 2, gravity = 2
Type ball
x As Single
y As Single
a As Single
dx As Single
dy As Single
sc As Single
pr As Single
pg As Single
pb As Single
pn As Single
End Type
Dim Shared b(1 To nBalls) As ball
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20 'this fits my screen yours may be different
Randomize Timer
Dim i As Integer, j As Integer, b As Integer, power, sky As Long
For i = 1 To nBalls
newBall i
Next
sky = _NewImage(xmax, ymax, 32)
_Dest sky&
For i = 0 To ymax
Line (0, i)-(xmax, i), _RGB32(100 + i / ymax * 40, 100 + i / ymax * 50, 160 + i / ymax * 95)
Next
_Dest 0
While _KeyDown(27) = 0
_PutImage , sky&, 0
For i = 1 To nBalls
'ready for collision
b(i).a = _Atan2(b(i).dy, b(i).dx)
power = (b(i).dx ^ 2 + b(i).dy ^ 2) ^ .5
For j = i + 1 To nBalls
If Sqr((b(i).x - b(j).x) ^ 2 + (b(i).y - b(j).y) ^ 2) < 200 * (b(i).sc + b(j).sc) Then
b(i).a = _Atan2(b(i).y - b(j).y, b(i).x - b(j).x)
b(j).a = _Atan2(b(j).y - b(i).y, b(j).x - b(i).x)
Exit For
End If
Next
b(i).dx = power * Cos(b(i).a)
b(i).dy = power * Sin(b(i).a)
b(i).dy = b(i).dy + gravity
b(i).x = b(i).x + b(i).dx
b(i).y = b(i).y + b(i).dy '+ 2 * gravity
If b(i).x < -200 * b(i).sc Or b(i).x > xmax + 200 * b(i).sc Then
newBall i
End If
If b(i).y + 220 * b(i).sc > ymax Then
b(i).y = ymax - 220 * b(i).sc
b(i).dy = b(i).dy * -.8
If b(i).dx = 0 Then b(i).dx = rdir Else b(i).dx = b(i).dx * 1.03
End If
drawBall i
Next
_Display
Wend
Sub drawBall (i)
Dim w, r, e, tmp, p, x, y, lc As Long
w = ww 'fix
For r = 190 To 0 Step -.25
e = w - pi / 4 / (490 - 300)
tmp = e: e = w: w = tmp
For p = 0 To pi Step pi / 144
e = Int((Cos(w) * 380) / 2)
x = b(i).x + e * b(i).sc * Cos(p * 2)
y = b(i).y - 90 * b(i).sc + e * b(i).sc * Sin(p * 2) + r * b(i).sc
lc = lc + 1
If lc Mod 25 = 0 Then
fcirc x, y, 6 * b(i).sc, plasma~&(i)
End If
Next
Next
End Sub
Sub newBall (i)
b(i).x = Rnd * xmax - 40 + 20
b(i).y = Rnd * -200
b(i).dx = rand(1, 3) * rdir
b(i).dy = rand(-5, 5)
b(i).sc = rand(2, 5) / 10
setRGB i
End Sub
Sub setRGB (i)
b(i).pr = Rnd ^ 3: b(i).pg = Rnd ^ 3: b(i).pb = Rnd ^ 3: b(i).pn = 1
End Sub
Function rand (lo, hi)
rand = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function
Function rdir ()
If Rnd < .5 Then rdir = -1 Else rdir = 1
End Function
'from Steve Gold standard
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
10x10 is an addictive puzzle game - much like the Woody puzzle in which this game is modeled after. To play, drag pieces onto the board to make completed lines (rows or columns). Completed lines will erase. Bonus points given for clearing more than one line at a time.
Game progress is saved so you can quit and resume later. Game ends when there's no space left of the board for pieces. Click on the 'Menu' at the top right to pop up the menu of options. You may also right click the mouse, or press M to bring up the menu. HI score is saved. Try to beat your own HI score.
This is the final version of 10x10 with updated graphics and sound effects. I'm not sure if this version ever was posted on the old forum. Here is is...
- Dav
============================================ NOTE: THERE’S A NEWER PORTABLE VERSION OF THIS GAME HERE ============================================
Given this new clean slate fresh start, I envision this as a place to repost some of my programs and/or links from the old forum. Maybe someone can get some ideas, or at least be amused by my random toddlings. Keeping things neat and contained in one thread to reduce clutter on the new forum.
This first one is my passion/obsession, years in the crafting and stumbling, which has grown in scope and support files/directories beyond just posting a code block. Made possible by QB64 as QBasic/4.5 just couldn't do it. While mostly still a work in progress, it's complete enough to call a "program".
CT Vector, is my turn based space flight vector tracker, a utility attempting to rescue the old Traveller RPG tabletop spaceship combat rules from obscurity. Likely no one who plays the game cares as no one bothered to use them for long, but I always wanted this sort of tool back in the day, and thought it would work, so I wrote one anyway. I'm funny that way... Even used it over the holidays, with somewhat mixed results. Many of the coding concepts I regularly use arose out of this mess, and many folks here will find their influence in it too.
A gamemaster can create and edit stellar systems [sysinput042.bas], whereupon the players can fly spacecraft through them. The system creator is still rather cryptic to use with some knowledge of the game and its canon concepts being helpful, but it does function with a few minor boogers. In lieu of that the tracker will default to the Sol system for demo purposes and the editor ap can be skipped. That's the easiest way to just "play around" with it. There are a couple of other systems included in the systems\ directory. I give a big "thank you" to Spriggsy for his pipecom API for making the loading process much more intuitive.
The tracker [CTvector052.bas] models game rules and is in no way an actual astrophysics or gravity simulator. "Damn it Jim, I'm a farmer, not an astrophysicist!" That said, large planets will attract nearby ships, so you gotta keep 'em flying or they'll crash. It can also take maneuvers to 3D, and resize and zoom in/out, which tabletop plotting could not do. Dates can optionally be input to track planetary ephemeris as the planets will move dynamically during play.
It's been a very long time since I posted any updates to it. My pièce de la résistance, which I have moved to Github. I added some OS metacommands to (hopefully) allow it to skip those commands that are not supported in Mac and Linux. Maybe it will run under those platforms now as well, with only a slight loss in mouse functionality. If anyone does try that, I'd appreciate a shout as to how it went.
In the tracker application, left click actuates controls, while right click & hold opens a context bubble explaining the controls function and hotkey access or moves ships in the sensor display. There is a badly "dated" user guide pdf included.
Browsing through the old forum @luke put up temporarily I found a drawing program I forgot about, QuadDraw, and decided to reawaken it. It would not work in our current QB64 version so I had to rewrite how it draws (it was using a recursive function that worked in QB64 v1.5 but not v2). Used a drawing method @bplus helped me with with another drawing project (doodle dandy).
I'm going to start working on this again and add more features. Here's where it's at so far. Draw on the screen by left clicking the mouse. Right clicking will fill spaces with a random color. U will undo last change. Brush size can be changed with -/+ keys. You can change how many section to draw at once by pressing numbers 1 to 4. Current drawing settings are visible in the title bar. I probably add a menu system and drawing color selector to it next.
Testers and suggestions are welcomed. Example drawing is attached.
- Dav
Code: (Select All)
'============
'QuadDraw.bas v1.3
'============
'An odd little drawing program.
'Draws/paints in 4 sections of the screen at same time.
'Coded by Dav for QB64 APR/2022
'NEW FOR v1.3: Fixed it to run in QB64 v2 and higher.
' (had to remove recursive drawing function)
' Screen size now adjusts to users desktop resolution.
' (size not hard coded - should look good on most desktops)
'CREDITS: SPAINT SUB was made by Petr. Thanks Petr!
' And bplus helped me figure out a way to draw lines without gaps
' in another program (doodle dandy). I used that new method here.
'----------
'HOW TO USE:
'----------
'Use the mouse to draw/color on screen.
'Left click = draws on screen.
'Right click = fills areas with color.
'Use the +/- keys to change brush size (1 to 50 allowed)
'Press 1,2,3 or 4 to set how many areas to draw in, default is 4.
'Press U to undo last change.
'Space = clears screen and starts over.
'ESC = Ends program
IF stilldown = 0 THEN
_FREEIMAGE undo&
undo& = _COPYIMAGE(_DISPLAY)
END IF
IF stilldown = 1 THEN
stepx = lastmx - mx
stepy = lastmy - my
length = INT((stepx ^ 2 + stepy ^ 2) ^ .5)
dx = stepx / length
dy = stepy / length
FOR i = 0 TO length
FOR d = 1 TO brushsize
newx = mx + dx * i: newy = my + dy * i
CIRCLE (newx, newy), d, blk&: PAINT (newx, newy), blk&, blk&
IF quads > 1 THEN
CIRCLE (centerx - newx + centerx, centery - newy + centery), d, blk&
PAINT (centerx - newx + centerx, centery - newy + centery), blk&, blk&
END IF
IF quads > 2 THEN
CIRCLE (newx, centery - newy + centery), d, blk&
PAINT (newx, centery - newy + centery), blk&, blk&
END IF
IF quads > 3 THEN
CIRCLE (centerx - newx + centerx, newy), d, blk&
PAINT (centerx - newx + centerx, newy), blk&, blk&
END IF
NEXT
NEXT
ELSE
FOR d = 1 TO brushsize STEP .2
CIRCLE (mx, my), d, blk&&
NEXT
END IF
lastmx = mx: lastmy = my
stilldown = 1
ELSE
stilldown = 0
END IF
'if right click, fill sections with random color
IF _MOUSEBUTTON(2) THEN
_FREEIMAGE undo&
undo& = _COPYIMAGE(_DISPLAY)
r = RND * 255: g = RND * 255: b = RND * 255
SPAINT mx, my, _RGB(r, g, b) ', blk&
IF quads > 1 THEN
SPAINT centerx - mx + centerx, centery - my + centery, _RGB(r, g, b) ', blk&
END IF
IF quads > 2 THEN
SPAINT mx, centery - my + centery, _RGB(r, g, b) ', blk&
END IF
IF quads > 3 THEN
SPAINT centerx - mx + centerx, my, _RGB(r, g, b) ', blk&
END IF
WHILE _MOUSEBUTTON(2) <> 0: n = _MOUSEINPUT: WEND
END IF
'get keyboard input
key$ = UCASE$(INKEY$)
IF key$ <> "" THEN
SELECT CASE key$
CASE CHR$(32): CLS , wht& 'scpace clears screen again
CASE "1": quads = 1
CASE "2": quads = 2
CASE "3": quads = 3
CASE "4": quads = 4
CASE "+"
brushsize = brushsize + 1: IF brushsize > 50 THEN brushsize = 50
CASE "-"
brushsize = brushsize - 1: IF brushsize < 1 THEN brushsize = 1
CASE "U": _PUTIMAGE (0, 0), undo&
CASE CHR$(27): END
END SELECT
DO UNTIL INKEY$ = "": LOOP
GOTO main
END IF
LOOP
END
SUB SPAINT (x AS INTEGER, y AS INTEGER, clr~&) 'Color everything in the X, Y position regardless of the border color.
'SUB by Petr
DIM m AS _MEM, m2 AS _MEM
m = _MEMIMAGE(_DEST)
W = _WIDTH(_DEST)
H = _HEIGHT(_DEST)
P = _PIXELSIZE(_DEST)
SELECT CASE P
CASE 4 ' image is 32 bit image
Virtual = _NEWIMAGE(W, H, 32)
m2 = _MEMIMAGE(Virtual)
Back~& = POINT(x, y)
Back2~& = _RGB32(1, 1, 1)
Empty~& = _RGBA32(0, 0, 0, 0)
DO UNTIL a& = m.SIZE - 4
a& = a& + 4
IF _MEMGET(m, m.OFFSET + a&, _UNSIGNED LONG) = Back~& THEN _MEMPUT m2, m2.OFFSET + a&, Back~& ELSE _MEMPUT m2, m2.OFFSET + a&, Back2~&
LOOP
d = _DEST
_DEST Virtual
PAINT (x, y), clr~&, Back2~&
_DEST d
a& = 0
DO UNTIL a& = m.SIZE - 4
a& = a& + 4
IF _MEMGET(m2, m2.OFFSET + a&, _UNSIGNED LONG) <> clr~& THEN _MEMPUT m2, m2.OFFSET + a&, Empty~&
LOOP
_CLEARCOLOR Back2~&, Virtual
_PUTIMAGE (0, 0), Virtual
_MEMFREE m
_MEMFREE m2
_FREEIMAGE Virtual
CASE 1 ' image is 8 bit image (256 colors)
Virtual = _NEWIMAGE(W, H, 32)
m2 = _MEMIMAGE(Virtual)
Back~& = POINT(x, y)
Back2~& = _RGB(1, 1, 1)
Empty~& = _RGBA(0, 0, 0, 0)
DO UNTIL a& = m.SIZE - 1
a& = a& + 1
IF _MEMGET(m, m.OFFSET + a&, _UNSIGNED _BYTE) = Back~& THEN _MEMPUT m2, m2.OFFSET + a&, Back~& ELSE _MEMPUT m2, m2.OFFSET + a&, Back2~&
LOOP
d = _DEST
_DEST Virtual
PAINT (x, y), clr~&, Back2~&
_DEST d
a& = 0
DO UNTIL a& = m.SIZE - 1
a& = a& + 1
IF _MEMGET(m2, m2.OFFSET + a&, _UNSIGNED _BYTE) <> clr~& THEN _MEMPUT m2, m2.OFFSET + a&, Empty~&
LOOP
_CLEARCOLOR Back2~&, Virtual
_PUTIMAGE (0, 0), Virtual
_MEMFREE m
_MEMFREE m2
_FREEIMAGE Virtual
END SELECT
END SUB
Posted by: Pete - 04-24-2022, 05:37 PM - Forum: Programs
- No Replies
Whenever we had a graphics emergency at The QBasic Forum, we always put up the Bat Signal ^^0^^ to call on TheBOB (aka The Batman) for help. One of Bob's creations, a recipe for White cake, and his Page Flipping Screen 9 demo were combined in the following code, but something went amiss that day in Gotham City...
Code: (Select All)
DEFINT A-Y
TYPE RockTYPE 'establish data TYPE for meteors
Mx AS INTEGER 'meteor x coordinate
My AS INTEGER 'meteor y coordinate
Mr AS INTEGER 'meteor radius (fixed)
Ms AS INTEGER 'meteor speed (fixed)
END TYPE
SCREEN 12, 0, 0, 0
_FULLSCREEN
FOR n = 1 TO 9
READ Attribute: OUT &H3C8, Attribute
FOR Reps = 1 TO 3
READ Intensity: OUT &H3C9, Intensity
NEXT Reps
NEXT n
PRINT
PRINT
COLOR 15
PRINT SPACE$(4); "W H I T E"; SPACE$(3); "C A K E"; SPACE$(3); "R E C I P E"
LINE (16, 60)-(620, 60), 9
LINE (16, 62)-(620, 62), 9
LINE (418, 60)-(542, 62), 0, BF
PRINT
PRINT
COLOR 12
PRINT SPACE$(4); "Heat oven to 350 degrees"
PRINT SPACE$(4); "Grease and flour 2 circular pans (8-9 inches)"
PRINT
COLOR 15
PRINT SPACE$(4); "CAKE:";
COLOR 11
PRINT SPACE$(9); "Flour: 2-1/4 cups"
PRINT SPACE$(18); "Sugar: 1-2/3 cups"
PRINT SPACE$(13); "Shortening: 2/3 cup"
PRINT SPACE$(19); "Milk: 1-1/4 cups"
PRINT SPACE$(10); "Baking powder: 3-1/2 tsps"
PRINT SPACE$(19); "Salt: 1 tsp"
PRINT SPACE$(16); "Vanilla: 1 tsp"
PRINT SPACE$(13); "Egg whites: 5 (reserve yolks for icing)"
PRINT
COLOR 12
PRINT SPACE$(4);
PRINT "Combine all ingredients except the egg whites in a bowl. Beat for 1/2"
PRINT SPACE$(4);
PRINT "minute at low speed, scraping bowl constantly, then 2 minutes at high"
PRINT SPACE$(4);
PRINT "speed, scraping bowl occasionally. Beat in egg whites, 2 minutes at"
PRINT SPACE$(4);
PRINT "high speed. Pour into pans. Bake until a toothpick inserted comes out"
PRINT SPACE$(4);
PRINT "clean or cake springs back when touched lightly (30 - 35 minutes)."
PRINT
COLOR 15
PRINT SPACE$(4); "ICING:";
COLOR 11
PRINT SPACE$(3); "Shortening: 2/3 cup"
PRINT SPACE$(17); "Butter: 2/3 cup"
PRINT SPACE$(14); "Egg yolks: 5"
PRINT SPACE$(16); "Vanilla: 1-1/2 tsps"
PRINT SPACE$(12); "Icing sugar: 3/4 cup or to taste"
CIRCLE (480, 86), 74, 1, , , .4
PAINT STEP(0, 0), 1
CIRCLE (480, 80), 72, 15, , , .4
PAINT STEP(0, 0), 15
CIRCLE (480, 79), 67, 9, , , .4
PAINT STEP(0, 0), 9
CIRCLE (480, 80), 72, 14, , , .4
CIRCLE (480, 78), 48, 15, , , .4
CIRCLE (480, 40), 60, 7, -4.5, -3.5, .4
PSET (423, 46), 7: DRAW "F2"
PAINT STEP(0, -10), 7
CIRCLE (480, 80), 60, 7, -4.5, -3.5, .4
PSET (423, 86), 7: DRAW "F2"
PAINT STEP(0, -10), 7
LINE (540, 40)-STEP(0, 40), 7
LINE (420, 40)-STEP(0, 40), 7
PAINT (430, 60), 7
PAINT (530, 60), 7
LINE (420, 40)-STEP(0, 40), 7
LINE STEP(4, -33)-STEP(0, 40), 7
LINE STEP(43, -24)-STEP(0, 40), 7
PAINT STEP(8, -18), 7
CIRCLE (480, 40), 60, 15, -4.5, -3.5, .4
LINE (540, 40)-STEP(0, 40), 15
LINE (420, 40)-STEP(0, 40), 15
LINE (420, 40)-STEP(0, 40), 15
LINE STEP(4, -33)-STEP(0, 40), 15
LINE STEP(43, -24)-STEP(0, 40), 15
PSET (430, 52), 4
DRAW "M+47,-7 M-9,+14 M-38,+6 U12 BR12 P4,4 BL13 D12 LU13Ld13"
PSET (427, 70), 4
DRAW "M+40,-7 D19 M-40,+7 U19 BF8 P4,4"
DIM Box(1000)
GET (427, 53)-(467, 78), Box()
PUT (427, 55), Box(), PSET
PSET (481, 40), 15
DRAW "M-13,+21"
PAINT (470, 30), 13, 15
FOR Reps = 1 TO 1200
X = FIX(RND * 60) + 420
y = FIX(RND * 54) + 40
IF POINT(X, y) = 4 THEN PSET (X, y), 15
NEXT Reps
PSET (427, 70), 2
DRAW "bM+40,-7 bD19 M-40,+7"
PSET (427, 70), 2
DRAW "bM+40,-7 bD20 M-30,+5"
CIRCLE (480, 80), 60, 2, 4.5, 6, .4
LINE (4, 4)-(635, 475), 9, B
FOR X = 524 TO 525
FOR y = 30 TO 100
IF POINT(X, y) = 7 THEN PSET (X, y), 13
NEXT y
NEXT X
FOR X = 528 TO 540
FOR y = 30 TO 100
IF POINT(X, y) = 7 THEN PSET (X, y), 13
NEXT y
NEXT X
CALL BSU
CALL SPACE
SYSTEM
PaletteDATA:
DATA 0,0,0,36,1,0,0,24,2,48,36,44,4,54,54,63,7,63,48,48,8
DATA 54,54,54,9,60,48,63,12,42,42,42,13,63,52,52,14,63,42,24
DO
b$ = INKEY$
_LIMIT 30
LOCATE 28, 62
PRINT "Press arrow up.";
LOCATE 28, 62
IF b$ = CHR$(0) + "H" THEN EXIT DO
_DELAY .45
PRINT " ";
IF b$ = CHR$(0) + "H" THEN EXIT DO
_DELAY .45
IF b$ = CHR$(27) THEN SYSTEM
LOOP UNTIL b$ = CHR$(0) + "H"
b$ = CHR$(13)
LOCATE 28, 60: PRINT " ";
FIREMISSILE:
FOR I = 1 TO 25
LOCATE 28 - I, 60: PRINT " ";
LOCATE CSRLIN - 1, 60: PRINT CHR$(24);
Z = TIMER
DO
LOOP UNTIL ABS(Z - TIMER) >= .02: 'DELAY LOOP
NEXT
FOR I = 1 TO 5
SOUND 2000, 2: SOUND 500, 2
WAIT &H3DA, 8
WAIT &H3DA, 8, 8
OUT &H3C8, 12
IF I >= 3 THEN
IF I / 2 <> I \ 2 THEN OUT &H3C8, 33 ELSE OUT &H3C8, 0
ELSE
OUT &H3C8, 0
OUT &H3C9, 63 'set background (briefly) to bright red
OUT &H3C9, 0
OUT &H3C9, 0
END IF
NEXT I
Z = TIMER
DO
LOOP UNTIL ABS(Z - TIMER) >= 1.5: 'DELAY LOOP
END SUB
SUB SPACE
SCREEN 9
'Set all attributes to black to hide draw/GET process
FOR n = 1 TO 15
PALETTE n, 0
NEXT n
'Ships differ in that the ship 2 rocket blasts are slightly larger
'Draw and GET ship 1 and mask
X = 0: Y = 0
MaxWIDTH = 83
MaxDEPTH = 60
DIM Rocks(1 TO 100) AS RockTYPE 'holds the location, size
'and speed of 100 meteors
IF X < 326 THEN
FOR n = 1 TO 100 'loop to initialize meteor array
SELECT CASE n 'speed variations create perspective
CASE 1 TO 30: Rocks(n).Ms = 12 'background meteors
CASE 31 TO 65: Rocks(n).Ms = 18 'midground meteors
CASE 66 TO 100: Rocks(n).Ms = 24 'foreground meteors
END SELECT
NEXT n
Rocks(50).Mr = 10 'meteor 50 specially sized (large)
Rocks(100).Mr = 16 'meteor 100 specially sized (larger)
ELSE
Z = TIMER: DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
LOOP
END IF
PALETTE
PALETTE 10, 0 'set palette values for attributes
PALETTE 12, 35 'which do not respond to OUT
'set palette values for attributes
'that respond to OUT
OUT &H3C8, 0
OUT &H3C9, 0
OUT &H3C9, 0 'background: midnight blue
OUT &H3C9, 12
OUT &H3C8, 1
OUT &H3C9, 16
OUT &H3C9, 8 'meteor: dark brown
OUT &H3C9, 2
OUT &H3C8, 2
OUT &H3C9, 32
OUT &H3C9, 32 'medium ship gray
OUT &H3C9, 32
OUT &H3C8, 3
OUT &H3C9, 22
OUT &H3C9, 12 'meteor highlight brown
OUT &H3C9, 5
OUT &H3C8, 4
OUT &H3C9, 63
OUT &H3C9, 0 'bright red
OUT &H3C9, 0
OUT &H3C8, 5
OUT &H3C9, 52
OUT &H3C9, 52 'ship light gray
OUT &H3C9, 52
'MAIN LOOP BEGINS -------------------------------
Count = 0
FOR X = 6 TO 546 STEP 2 'main loop wherein ship will
_DELAY .115 ' Reading speed
'travel 540 pixels in steps
'of two
CLS 'active screen cleared
OUT &H3C8, 0 'background color reestablished
OUT &H3C9, 0 'in case "space lightning" has
OUT &H3C9, 0 'flashed
OUT &H3C9, 12
'The following loop draws/updates x/y's of first 80 meteors
IF X < 326 THEN
FOR n = 1 TO 80
GOSUB DrawMETEORS 'see DrawMETEORS subroutine
NEXT n
'Second meteor-drawing loop draws last 20 meteors so that they *may*
'overdraw the ship (creating sense of its 'involvement' in meteor storm)
FOR n = 81 TO 100
GOSUB DrawMETEORS 'see DrawMETEORS subroutine
NEXT n
ELSE
''Z = TIMER: DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
''LOOP
END IF
Z = TIMER: DO: IF ABS(Z - TIMER) > .05 THEN EXIT DO
LOOP
'PRINT section -------------------------------------
'Blurbs are printed (with gaps) based on the ship's x location
COLOR 13: A1 = 30
SELECT CASE X
CASE 10 + A1 TO 100 + A1
LOCATE 21, 19: PRINT "Kirk to Spock. What are those strange looking"
LOCATE 22, 31: PRINT "blobs on the screen?"
CASE 101 + A1 TO 170 + A1
LOCATE 21, 21: PRINT "Sensors indicate they are the remains of"
LOCATE 22, 23: PRINT "TheBob's White Cake Recipe, Captain."
CASE 171 + A1 TO 240 + A1
LOCATE 21, 15: PRINT "Kirk to Scottie. Beam those pieces of cake on board!"
CASE 241 + A1 TO 317 + A1
LOCATE 21, 19: PRINT "Aye Captain, I'll get right on it, as soon as"
LOCATE 22, 28: PRINT "I finish my Dunkin Donuts."
CASE 336 + A1 TO 435 + A1
LOCATE 21, 15: PRINT "Kirk to Sick Bay. Bones, MEDICAL EMERGENCY! Report to"
LOCATE 22, 13: PRINT "the Transporter Room and put TheBob's cake back together!"
CASE IS > 440 + A1
LOCATE 21, 19: PRINT "Dammit Jim. I'm a doctor, not Martha Stewart!"
END SELECT
'-----------------------------------------------------
'Border line
LINE (0, 0)-(639, 349), 8, B
'"Space lightning" flash (1 chance in 25)
'Flash = FIX(RND * 25)
IF X = 326 THEN
SOUND 1000, .5: SOUND 2000, .5: SOUND 3000, .5: SOUND 4000, .5: SOUND 5000, .5: SOUND 6000, .5
SOUND 6000, .5: SOUND 7000, .5: SOUND 8000, .5: SOUND 4000, .5: SOUND 9000, .5
OUT &H3C8, 0
OUT &H3C9, 63 'set background (briefly) to bright red
OUT &H3C9, 0
OUT &H3C9, 0
END IF
SCREEN 9, 0, 0, 0
LOCATE 21, 5: PRINT SPACE$(70);
LOCATE 22, 5: PRINT SPACE$(70);
_DELAY 1
LEVEL1 = 10
A1$ = " [Sometimes The Joker Wins!]"
REDIM BAT$(3)
BAT$(3) = "^^o^^"
BAT$(2) = "--o--"
BAT$(1) = "vvovv"
LOCATE LEVEL1, 2
_DELAY 1
FOR I = 1 TO 12
FOR J = 1 TO 3
IF I = 1 AND J = 1 THEN LOCATE , 3 ELSE PRINT " ";
PRINT BAT$(J);
LOCATE , POS(1) - 5
Z = TIMER
DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
LOOP
NEXT J
NEXT I
_DELAY 1
FOR I = 2 TO LEVEL1
IF I = LEVEL1 - 1 THEN SOUND 3000, .7: SOUND 358, 1.5: SOUND 5000, 1
IF I <> 2 THEN LOCATE I - 1, 27: PRINT SPACE$(28);
LOCATE I, 27: PRINT A1$;
Z = TIMER
DO: IF ABS(Z - TIMER) > .1 THEN EXIT DO
LOOP
NEXT
'If the meteor's x coordinate has moved off-screen to the left, it is as-
'signed a new random y coordinate, then reset to the right of the screen
IF Rocks(n).Mx < 0 THEN
Rocks(n).My = FIX(RND * 350)
Rocks(n).Mx = 642
END IF
'Meteors are drawn with lighter highlight circle offset +1/-1 pixel
CIRCLE (Rocks(n).Mx, Rocks(n).My), Rocks(n).Mr, 1
PAINT STEP(0, 0), 1
CIRCLE (Rocks(n).Mx + 1, Rocks(n).My - 1), Rocks(n).Mr - 2, 3
PAINT STEP(0, 0), 3
'Establish new location for each meteor by subtracting their
'individual speed (Ms) from their current x coordinate (Mx) ...
Rocks(n).Mx = Rocks(n).Mx - Rocks(n).Ms
RETURN
Mask:
FOR xx = 0 TO 83
FOR yy = 0 TO 60
IF POINT(xx, yy) = 0 THEN PSET (xx, yy), 15 ELSE PSET (xx, yy), 0
NEXT yy
NEXT xx
RETURN
