| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 746
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 29
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 28
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 1,882
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,182
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 309
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 117
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,317
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 230
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 137
|
|
|
| Old Modem Program |
|
Posted by: Abacus - 04-19-2022, 08:59 AM - Forum: Programs
- Replies (7)
|
 |
Posting an old program from my 2006 backup disk of archived files. I hope someone will find it interesting.
Code: (Select All) Cls
Print "Simple Qbasic communications program."
Print "What COM port does your modem use?"
Input ">", port$
baud$ = "9600" '9600 should work fine with most modems. If you have
'an older one use 2400.
'Open up that com port.
Open "COM" + port$ + ":" + baud$ + ",N,8,1,RB2048,TB2048" For Random As #1
Print "OPTIONS:"
Print "1-Dial up to another computer"
Print "2-Wait for a call"
Print "3-Quit"
Do
a = Val(InKey$)
Loop Until a >= 1 And a <= 3
If a = 3 Then Close: System
If a = 2 Then GoTo waitfor
Print "Number to call?"
Input ">", number$
Print #1, "ATDT" + number$ 'Tell the modem to dial the number.
GoTo chat
waitfor:
Print #1, "ATS0=1" 'Tell modem to connect after 1 ring.
'When a modem connects it returns "CONNECT ####"
'The next hunk of code waits until the modem connects before moving on
a$ = ""
Do
If Loc(1) Then a$ = a$ + Input$(1, 1) 'if anything in modem add it to a$
Loop Until InStr(a$, "CONNECT") 'Wait until modem have connected.
chat:
'If you where waiting for a call, a lot of ASCII characters will be printed
'on the screen. Don't worry, that's just the computers getting in sync and
'talking. You also will not see what you type.
Cls
Print "You are now ready to chat, press ESC to quit."
Do
t$ = InKey$
If Len(t$) Then Print #1, t$ 'if you typed something send it to the modem
'this will be send by the modem to the other
'computer
If Loc(1) Then r$ = Input$(1, 1) 'if the is something to get, get it and save
'it as r$
If Len(r$) Then Print r$; 'if r$ <> "" then print it. the ";" means a
'line is not started
Loop Until t$ = Chr$(27) 'keep doing this until ESC is pressed
Print #1, "ATZ" 'tell the modem to hang up
Close 'close the open com statement
|
|
|
| What Happened? |
|
Posted by: Tim - 04-19-2022, 04:12 AM - Forum: General Discussion
- Replies (53)
|
 |
So, obviously something major has happened to qb64.org. And I just started to use qb64--and very happily. My question is, what did happen? I am completely out of the loop.
|
|
|
|
| QB64 Independence Day by Not Really Martina McBride |
|
Posted by: Pete - 04-19-2022, 02:48 AM - Forum: General Discussion
- Replies (2)
|
 |
I could have told ya this guy R C Cola
Would turn out to be a dangerous man
But when Fell found out, in a Discord rout
It was too late to come up with a plan
Now the forum's down, Youtube is not around
And the Odin's went their separate way
So Steve started up a revolution, it's Independence Day
Let Free Speech ring, let your posts be heard
Let everyone have a ton of fun and help spread the word
Good to be a part, of this brand new start
Throw dot org away, Phoenix is here to stay, It's Independence Day
Throw dot org away
It's Independence Day
-------------------------------
So no, despite the appearance o my avatar, I'm not really a big country music fan, but who couldn't love listening to Martina McBride?
https://www.youtube.com/watch?v=4VPpAZ9_qAw
You may want to fast forward the 30sec preamble.
Pete
|
|
|
|
| qbs_str my mod |
|
Posted by: Jack - 04-19-2022, 01:18 AM - Forum: General Discussion
- Replies (9)
|
 |
as seen here https://staging.qb64phoenix.com/showthre...114#pid114 I worked on changing the qbs_str function for double and float
I went ahead and incorporated the changes in libqb.cpp and built QB64, here's a sample
Code: (Select All) $Console:Only
_Dest _Console
Print Factorial_Recursive(1000)
Function Factorial_Recursive## (n As Integer)
If n = 0 Then Factorial_Recursive## = 1: Exit Function
Factorial_Recursive## = n * Factorial_Recursive##(n - 1)
End Function
Quote:4.02387260077093773F+2567
Press any key to continue
even though I did some testing for bugs some may have slipped trough
looks like I found a bug, not ready for prime-time
it has a strange effect on print using
Code: (Select All) $Console:Only
_Dest _Console
Dim As _Float f
f = Factorial_Recursive(50)
Print Using "##.##################"; f
Print f
Function Factorial_Recursive## (n As Integer)
If n = 0 Then Factorial_Recursive## = 1: Exit Function
Factorial_Recursive## = n * Factorial_Recursive##(n - 1)
End Function
Quote:%30414093201713378039796484017234741538658648106343392576177963008.000000000000000000
3.0414093201713378F+64
Press any key to continue
|
|
|
|
| C code sanity check |
|
Posted by: Jack - 04-18-2022, 04:39 PM - Forum: Help Me!
- Replies (1)
|
|
would you guys test the following code for logic errors?
the goal here is to replace the current double to string conversion that's faulty in QB64
I must have concluded at least a dozen times that all was ok only to discover a bug
[edit1]
restricted the maximum digits to 15, with 16 digits there are too many cases that suffer from floating-point inaccuracies, like trying to print 1d-21 would give 9.999999999999999d-22
[edit2]
added a test program, let me know what you think
[edit3]
added another test
Code: (Select All) #include <stdio.h>
#include <stdlib.h>
#include <stdint.h>
#include <time.h>
#define QB64_MINGW
int str(double value){
char buf[64];
char buf2[64];
int32_t i, j, lsd, exp;
//double value=.000000000000000000001; //3.141592653589e3; //3.141592653589793e-10;
#ifdef QB64_MINGW
__mingw_sprintf((char*)&buf,"% .14Le",(long double) value);
#else
sprintf((char*)&buf,"% .14Le",(long double) value);
#endif
exp=atoi(&buf[18]);
lsd=16;
while((buf[lsd]=='0')&&(lsd>0)) lsd--;
buf2[0]=buf[0]; // copy sign
if(exp==0){
for(i=1;i<=(lsd);i++){
buf2[i]=buf[i];
}
if(buf2[lsd]=='.') // if no digits after . then nip it
buf2[lsd]=0; // by zero terminating
else
buf2[lsd+1]=0; // zero terminate
}
else if(exp<0){
if((lsd-exp)>=19){ // use sci format
for(i=1;i<=lsd;i++){
buf2[i]=buf[i];
}
if(buf2[lsd]=='.'){
buf2[lsd]='D';
sprintf(&buf2[lsd+1],"%+03d", exp);
}
else{
buf2[lsd+1]='D';
sprintf(&buf2[lsd+2],"%+03d", exp);
}
}
else{
buf2[1]='.';
for(i=2;i<=abs(exp);i++){
buf2[i]='0';
}
buf2[abs(exp)+1]=buf[1]; // first non-zero digit
j=3; // skip decimal point
for(i=abs(exp)+2;i<(abs(exp)+lsd);i++){
buf2[i]=buf[j];
j++;
}
buf2[abs(exp)+lsd]=0; // zero terminate
}
}
else if(exp>0){
if((lsd<17)&&(exp<15)){
buf2[1]=buf[1]; // first digit
j=3; // skip over .
for(i=2;i<=(exp+1);i++){
buf2[i]=buf[j];
j++;
}
if((lsd>exp)&&(lsd>(j-1))){
buf2[exp+2]='.';
for(i=exp+3;i<=(lsd);i++){
buf2[i]=buf[j];
j++;
}
buf2[lsd+1]=0;
}
else{
buf2[exp+2]=0;
}
}
else{
for(i=0;i<=lsd;i++){
buf2[i]=buf[i];
}
if(buf2[lsd]=='.'){
buf2[lsd]='D';
sprintf(&buf2[lsd+1],"%+03d", exp);
}
else{
buf2[lsd+1]='D';
sprintf(&buf2[lsd+2],"%+03d", exp);
}
}
}
printf("%s", buf2);
return 0;
}
int main(void){
time_t t;
double x;
char* ptr;
char strx[50]="3141592653589793";
char c;
int i, j, k;
srand((unsigned) time(&t));
for(i=1;i<3;i++){
for(j=1;j<15;j++){
k=rand() %j;
c=strx[k];
strx[k]='.';
x=strtod(strx,&ptr);
str(x); printf("% .14e %s\n",x,strx);
strx[k]=c;
}
}
printf("%s\n","====================================================");
char stry[50]="3.141592653589793e";
for(i=1;i<3;i++){
for(j=1;j<15;j++){
k=rand() %j;
k=k * (13 - (-13)) + (-13);
sprintf(&stry[18],"%d", k);
x=strtod(stry,&ptr);
str(x); printf("% .14e %s\n",x,stry);
}
}
printf("%s\n","====================================================");
strx[0]='1';
for(j=1;j<41;j++){
for(i=1;i<=j;i++){
strx[i]='0';
}
strx[i]=0;
x=strtod(strx,&ptr);
str(x); printf("% .14e %s\n",x,strx);
}
printf("%s\n","====================================================");
strx[0]='.';
for(j=1;j<41;j++){
for(i=1;i<=j;i++){
strx[i]='0';
}
strx[i]='1';
strx[i+1]=0;
x=strtod(strx,&ptr);
str(x); printf("% .14e %s\n",x,strx);
}
return 0;
}
|
|
|
|
| libtommath bignum for Win-64 |
|
Posted by: Jack - 04-18-2022, 02:31 PM - Forum: One Hit Wonders
- Replies (1)
|
|
this is header translation for 64-bit QB64 on Windows x64 of LibTomMath https://www.libtom.net/
LibTomMath is in the public domain, no strings attached
LibTomMath.bi
Code: (Select All) $If 64BIT Then
Const MP_28BIT = 0
Const MP_64BIT = 1
' Type _unsigned _integer64
' As _Unsigned _Integer64 mpdigit
' End Type
Type private_mp_word
As String * 128 mpword
End Type
Const MP_DIGIT_BIT = 60
$Else
Type _unsigned _integer64
mpdigit As _Unsigned Long
End Type
Type private_mp_word
mpword As _Unsigned _Integer64
End Type
Const _unsigned _integer64_BIT = 28
Const MP_28BIT = 1
Const MP_64BIT = 0
$End If
Type mp_int
used As Long
alloc As Long
sign As Long
dp As _Offset
End Type
Declare Dynamic Library "libtommath"
Function mp_init& (a As mp_int) ' as mp_err
Function mp_init_size& (a As mp_int, Byval size As Long) ' as mp_err
Function mp_init_i32& (a As mp_int, Byval b As Long) ' as mp_err
Function mp_init_l& (a As mp_int, Byval b As Long) ' ' as mp_err
Function mp_init_u32& (a As mp_int, Byval b As _Unsigned Long) ' as mp_err
Function mp_init_ul& (a As mp_int, Byval b As _Unsigned Long) ' as mp_err
Function mp_init_i64& (a As mp_int, Byval b As _Integer64) ' as mp_err
Function mp_init_ll& (a As mp_int, Byval b As _Integer64) ' as mp_err
Function mp_init_u64& (a As mp_int, Byval b As _Unsigned _Integer64) ' as mp_err
Function mp_init_ull& (a As mp_int, Byval b As _Unsigned _Integer64) ' as mp_err
Function mp_init_set& (a As mp_int, Byval b As _Unsigned _Integer64) ' as mp_err
Function mp_init_set_int& (a As mp_int, Byval b As _Unsigned Long) ' as mp_err
Function mp_init_copy (a As mp_int, b As mp_int) ' as mp_err
Sub mp_clear (a As mp_int)
Sub mp_exch (a As mp_int, b As mp_int)
Function mp_shrink& (a As mp_int) ' as mp_err
Function mp_grow& (a As mp_int, Byval size As Long) ' as mp_err
Function mp_iseven& (a As mp_int) ' as long
Function mp_isodd& (a As mp_int) ' as long
Sub mp_zero (a As mp_int)
Function mp_get_double# (a As mp_int) ' as double
Function mp_set_double& (a As mp_int, Byval b As Double) ' as mp_err
Function mp_get_i32& (a As mp_int) ' as long
Function mp_get_l& (a As mp_int) ' as long
Function mp_get_int~& (a As mp_int) ' as ulong
Function mp_get_long~& (a As mp_int) ' as ulong
Function mp_get_i64&& (a As mp_int) ' as longint
Function mp_get_ll&& (a As mp_int) ' as longint
Function mp_get_long_long~&& (a As mp_int) ' as ulongint
Sub mp_set_i32 (a As mp_int, Byval b As Long)
Sub mp_set_l (a As mp_int, Byval b As Long)
Function mp_set_long& (a As mp_int, Byval b As _Unsigned Long) ' as mp_err
Sub mp_set_u32 (a As mp_int, Byval b As _Unsigned Long)
Sub mp_set_ul (a As mp_int, Byval b As _Unsigned Long)
Function mp_set_int& (a As mp_int, Byval b As _Unsigned Long) ' as mp_err
Sub mp_set_i64 (a As mp_int, Byval b As _Integer64)
Function mp_set_long_long& (a As mp_int, Byval b As _Unsigned _Integer64) ' as mp_err
Sub mp_set_ll (a As mp_int, Byval b As _Integer64)
Sub mp_set_u64 (a As mp_int, Byval b As _Unsigned _Integer64)
Sub mp_set_ull (a As mp_int, Byval b As _Unsigned _Integer64)
Sub mp_set (a As mp_int, Byval b As _Unsigned _Integer64)
Function mp_get_mag_u32~& (a As mp_int) ' as ulong
Function mp_get_mag_ul~& (a As mp_int) ' as ulong
Function mp_get_mag_u64~&& (a As mp_int) ' as ulongint
Function mp_get_mag_ull~&& (a As mp_int) ' as ulongint
Function mp_copy (a As mp_int, b As mp_int) ' as mp_err
Sub mp_clamp (a As mp_int)
Function mp_export& (rop As _Offset, countp As _Unsigned Long, Byval order As Long, Byval size As _Unsigned Long, Byval endian As Long, Byval nails As _Unsigned Long, op As mp_int) ' as mp_err
Function mp_import& (rop As mp_int, Byval count As _Unsigned Long, Byval order As Long, Byval size As _Unsigned Long, Byval endian As Long, Byval nails As _Unsigned Long, Byval op As _Offset) ' as mp_err
Function mp_unpack& (rop As mp_int, Byval count As _Unsigned Long, Byval order As Long, Byval size As _Unsigned Long, Byval endian As Long, Byval nails As _Unsigned Long, op As _Offset) ' as mp_err
Function mp_pack_count~& (a As mp_int, Byval nails As _Unsigned Long, Byval size As _Unsigned Long) ' as uinteger
Function mp_pack& (rop As _Offset, Byval maxcount As _Unsigned Long, written As _Unsigned Long, Byval order As Long, Byval size As _Unsigned Long, Byval endian As Long, Byval nails As _Unsigned Long, op As mp_int) ' as mp_err
Sub mp_rshd (a As mp_int, Byval b As Long)
Function mp_lshd& (a As mp_int, Byval b As Long) ' as mp_err
Function mp_div_2d& (a As mp_int, Byval b As Long, c As mp_int, d As mp_int) ' as mp_err
Function mp_div_2& (a As mp_int, b As mp_int) ' as mp_err
Function mp_div_3& (a As mp_int, c As mp_int, d As _Unsigned _Integer64) ' as mp_err
Function mp_mul_2d& (a As mp_int, Byval b As Long, c As mp_int) ' as mp_err
Function mp_mul_2& (a As mp_int, b As mp_int) ' as mp_err
Function mp_mod_2d& (a As mp_int, Byval b As Long, c As mp_int) ' as mp_err
Function mp_2expt& (a As mp_int, Byval b As Long) ' as mp_err
Function mp_cnt_lsb& (a As mp_int) ' as long
Function mp_rand& (a As mp_int, Byval digits As Long) ' as mp_err
Function mp_rand_digit& (r As _Unsigned _Integer64) ' as mp_err
Function mp_get_bit& (a As mp_int, Byval b As Long) ' as long
Function mp_tc_xor& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_xor& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_tc_or& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_or& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_tc_and& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_and& (a As mp_int, b As mp_int, c As mp_int) 'as mp_err
Function mp_complement& (a As mp_int, b As mp_int) ' as mp_err
Function mp_tc_div_2d& (a As mp_int, Byval b As Long, c As mp_int) ' as mp_err
Function mp_signed_rsh& (a As mp_int, Byval b As Long, c As mp_int) ' as mp_err
Function mp_neg (a As mp_int, b As mp_int) ' as mp_err
Function mp_abs& (a As mp_int, b As mp_int) ' as mp_err
Function mp_cmp& (a As mp_int, b As mp_int) 'as mp_ord
Function mp_cmp_mag& (a As mp_int, b As mp_int) ' as mp_ord
Function mp_add& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_sub& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_mul& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_sqr& (a As mp_int, b As mp_int) ' as mp_err
Function mp_div& (a As mp_int, b As mp_int, c As mp_int, d As mp_int) ' as mp_err
Function mp_mod& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_incr& (a As mp_int) ' as mp_err
Function mp_decr& (a As mp_int) ' as mp_err
Function mp_cmp_d& (a As mp_int, Byval b As _Unsigned _Integer64) ' as mp_ord
Function mp_add_d& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int) ' as mp_err
Function mp_sub_d& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int) ' as mp_err
Function mp_mul_d& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int) ' as mp_err
Function mp_div_d& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int, d As _Unsigned _Integer64) ' as mp_err
Function mp_mod_d& (a As mp_int, Byval b As _Unsigned _Integer64, c As _Unsigned _Integer64) ' as mp_err
Function mp_addmod& (a As mp_int, b As mp_int, c As mp_int, d As mp_int) ' as mp_err
Function mp_submod& (a As mp_int, b As mp_int, c As mp_int, d As mp_int) ' as mp_err
Function mp_mulmod& (a As mp_int, b As mp_int, c As mp_int, d As mp_int) ' as mp_err
Function mp_sqrmod& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_invmod& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_gcd& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_exteuclid& (a As mp_int, b As mp_int, U1 As mp_int, U2 As mp_int, U3 As mp_int) ' as mp_err
Function mp_lcm& (a As mp_int, b As mp_int, c As mp_int) ' as mp_err
Function mp_root_u32& (a As mp_int, Byval b As _Unsigned Long, c As mp_int) ' as mp_err
Function mp_n_root& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int) ' as mp_err
Function mp_n_root_ex& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int, Byval fast As Long) ' as mp_err
Function mp_sqrt& (arg As mp_int, ret As mp_int) ' as mp_err
Function mp_sqrtmod_prime& (n As mp_int, prime As mp_int, ret As mp_int) ' as mp_err
Function mp_is_square& (arg As mp_int, ret As Long) ' as mp_err
Function mp_jacobi& (a As mp_int, n As mp_int, c As Long) ' as mp_err
Function mp_kronecker& (a As mp_int, p As mp_int, c As Long) ' as mp_err
Function mp_reduce_setup& (a As mp_int, b As mp_int) ' as mp_err
Function mp_reduce& (x As mp_int, m As mp_int, mu As mp_int) ' as mp_err
Function mp_montgomery_setup& (n As mp_int, rho As _Unsigned _Integer64) ' as mp_err
Function mp_montgomery_calc_normalization& (a As mp_int, b As mp_int) ' as mp_err
Function mp_montgomery_reduce& (x As mp_int, n As mp_int, Byval rho As _Unsigned _Integer64) ' as mp_err
Function mp_dr_is_modulus& (a As mp_int) ' as mp_bool
Sub mp_dr_setup (a As mp_int, d As _Unsigned _Integer64)
Function mp_dr_reduce& (x As mp_int, n As mp_int, Byval k As _Unsigned _Integer64) ' as mp_err
Function mp_reduce_is_2k& (a As mp_int) ' as mp_bool
Function mp_reduce_2k_setup& (a As mp_int, d As _Unsigned _Integer64) ' as mp_err
Function mp_reduce_2k& (a As mp_int, n As mp_int, Byval d As _Unsigned _Integer64) ' as mp_err
Function mp_reduce_is_2k_l& (a As mp_int) ' as mp_bool
Function mp_reduce_2k_setup_l& (a As mp_int, d As mp_int) ' as mp_err
Function mp_reduce_2k_l& (a As mp_int, n As mp_int, d As mp_int) ' as mp_err
Function mp_exptmod& (G As mp_int, X As mp_int, P As mp_int, Y As mp_int) ' as mp_err
Function mp_prime_is_divisible& (a As mp_int, result As Long) ' as mp_err
Function mp_prime_fermat& (a As mp_int, b As mp_int, result As Long) ' as mp_err
Function mp_prime_miller_rabin& (a As mp_int, b As mp_int, result As Long) ' as mp_err
Function mp_prime_rabin_miller_trials& (ByVal size As Long) ' as long
Function mp_prime_strong_lucas_selfridge& (a As mp_int, result As Long) ' as mp_err
Function mp_prime_frobenius_underwood& (N As mp_int, result As Long) ' as mp_err
Function mp_prime_is_prime& (a As mp_int, Byval t As Long, result As Long) ' as mp_err
Function mp_prime_next_prime& (a As mp_int, Byval t As Long, Byval bbs_style As Long) ' as mp_err
Function mp_prime_rand& (a As mp_int, Byval t As Long, Byval size As Long, Byval flags As Long) ' as mp_err
Function mp_log_u32& (a As mp_int, Byval base As _Unsigned Long, c As _Unsigned Long) ' as mp_err
Function mp_expt_u32& (a As mp_int, Byval b As _Unsigned Long, c As mp_int) ' as mp_err
Function mp_expt_d& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int) ' as mp_err
Function mp_expt_d_ex& (a As mp_int, Byval b As _Unsigned _Integer64, c As mp_int, Byval fast As Long) ' as mp_err
Function mp_count_bits& (a As mp_int) ' as long
Function mp_unsigned_bin_size& (a As mp_int) ' as long
Function mp_read_unsigned_bin& (a As mp_int, Byval b As _Offset, Byval c As Long) ' as mp_err
Function mp_to_unsigned_bin& (a As mp_int, Byval b As _Offset) ' as mp_err
Function mp_to_unsigned_bin_n& (a As mp_int, Byval b As _Offset, outlen As _Unsigned Long) ' as mp_err
Function mp_signed_bin_size& (a As mp_int) ' as long
Function mp_read_signed_bin& (a As mp_int, Byval b As _Offset, Byval c As Long) ' as mp_err
Function mp_to_signed_bin& (a As mp_int, Byval b As _Offset) ' as mp_err
Function mp_to_signed_bin_n& (a As mp_int, Byval b As _Offset, outlen As _Unsigned Long) ' as mp_err
Function mp_ubin_size~&& (a As mp_int) ' as uinteger
Function mp_from_ubin& (a As mp_int, Byval buf As _Offset, Byval size As _Unsigned _Integer64) ' as mp_err
Function mp_to_ubin& (a As mp_int, Byval buf As _Offset, Byval maxlen As _Unsigned _Integer64, written As _Unsigned _Integer64) ' as mp_err
Function mp_sbin_size~&& (a As mp_int) ' as uinteger
Function mp_from_sbin& (a As mp_int, Byval buf As _Offset, Byval size As _Unsigned _Integer64) ' as mp_err
Function mp_to_sbin& (a As mp_int, Byval buf As _Offset, Byval maxlen As _Unsigned _Integer64, written As _Unsigned _Integer64) ' as mp_err
Function mp_to_radix& (a As mp_int, str As String, Byval maxlen As _Unsigned _Integer64, written As _Unsigned _Integer64, Byval radix As Long) ' as mp_err
Function mp_radix_size& (a As mp_int, Byval radix As Long, size As Long) ' as mp_err
Function mp_read_radix& (a As mp_int, str As String, Byval radix As Long) ' as mp_err
Function mp_toradix (a As mp_int, str As String, Byval radix As Long) ' as mp_err
Function mp_toradix_n& (a As mp_int, str As String, Byval radix As Long, Byval maxlen As Long) ' as mp_err
End Declare
LibTomMath.bm
Code: (Select All) Function mp_str$ (n As mp_int, radix As Long)
Dim sresult As String
Dim As Long status, size
status = mp_radix_size&(n, radix, size)
sresult = Space$(size) + Chr$(0)
status = mp_toradix_n(n, sresult, radix, size)
If status = 0 Then
mp_str$ = _Trim$(sresult)
Else
mp_str$ = "error in mp_toradix"
End If
End Function
Sub mp_val (s As String, n As mp_int, radix As Long)
Dim value As String
Dim status As Long
Dim As Long ok
value = s + Chr$(0)
status = mp_read_radix(n, value, radix)
If status <> 0 Then Print "could not read number"
End Sub
testTomMath.bas
Code: (Select All) '$include: 'LibTomMath.bi'
Dim As mp_int n, m, r
Dim As Long ok
If mp_init(n) <> 0 Then Print "failed to initialize"
If mp_init(m) <> 0 Then Print "failed to initialize"
If mp_init(r) <> 0 Then Print "failed to initialize"
mp_val "2" + String$(100, "0"), n, 10
ok = mp_n_root&(n, 2, r)
Print mp_str(r, 10)
ok = mp_sqrt&(n, m)
Print mp_str(m, 10)
mp_clear r
mp_clear m
mp_clear n
'$include: 'LibTomMath.bm'
get the 64-bit dll
libtommath.zip (Size: 59.37 KB / Downloads: 61)
|
|
|
|
External Module Player (libxmp) support |
|
Posted by: RhoSigma - 04-18-2022, 09:44 AM - Forum: RhoSigma
- No Replies
|
 |
Libxmp is a library that renders module files to PCM data. It supports over 90 mainstream and obscure module formats including Protracker (MOD), Scream Tracker 3 (S3M), Fast Tracker II (XM), and Impulse Tracker (IT)
After almost 5 years, libxmp got lots of fixes plus a couple new features and finally version 4.5.0 was released. This was a good occasion for me to complete my wrapper library for it and to improve my demo player to showcase some of the libxmp functions and give a hint how to correctly use the wrapper library.
When porting the informations over into libxmp.bi/.bm and testing it, I found several badly described things and tried to correct/improve those with my own findings from examining the libxmp sources.
The XmpPlayer.bas file will espacially show the use of the various wrapper or helper functions in libxmp.bm, which are used to retrieve informations from the internal libxmp structures.
The player itself is almost self explanatory at runtime and programmed as an endless loop, so simply hit the X button of the player window to quit it at any time. It is able to show various informations about the current module and also features a wave oscillator and frequency spectrum (FFT) display, the latter thanks to Vince's Fast Fourier algorithms.
xmpDemo.7z (Size: 2.53 MB / Downloads: 44)
--- (Dec/22)(Libxmp wrapper library & demo player)
Note that this program requires the 32-bit version of QB64, as libxmp is currently available as 32-bit version only, this will hopefully change in the future. So here it is, just move the extracted xmpDemo folder with its entire contents into your QB64 installation folder, then open the QB64 IDE, untick the Save EXE in source folder option (if active (in Run Menu)), load XmpPlayer.bas from the xmpDemo folder, hit F5 and enjoy the music.
|
|
|
|
| Assassins 64: Blast from the past |
|
Posted by: kinem - 04-18-2022, 12:28 AM - Forum: Programs
- Replies (6)
|
 |
Here's my latest version of the old (2001) game. I've worked a bit on the bad guys' behavior recently, so it's a bit better (I think) than the version I posted recently on the old forum.
Code: (Select All) '1PSA64-3.BAS by Dr. Jacques Mallah (jackmallah@yahoo.com)
'Compile with QB64
DECLARE SUB endit () : DECLARE SUB onscreen () : DECLARE SUB paintsprites ()
DECLARE SUB medkit.etc () : DECLARE SUB showhealth () : DECLARE SUB badguys ()
DECLARE SUB yourmove () : DECLARE SUB time () : DECLARE SUB yourshot ()
DECLARE SUB crashtest (bx!, by!, vx!, vy!) : DECLARE FUNCTION atan2! (y!, x!)
DECLARE SUB showbadguy (b%) : DECLARE SUB showbadshot (x%) : DECLARE SUB showurshot (x%)
DECLARE SUB raycast () : DECLARE SUB btexture (xx%, dd%, bcc%, c%, bcc2%)
DECLARE SUB putcircle (x%, y%, R%, col%, circdis!) : DECLARE SUB showmed (b%)
DECLARE SUB putbox (x1!, y1%, x2!, y2%, col%, boxdis!): declare sub readmap()
DECLARE SUB intro () : DECLARE SUB maketables () : DECLARE SUB makeworld ()
DECLARE SUB hLINE (x1%, x2%, y%, c%) : DECLARE SUB vline (x%, yt%, yb%, c%), keys()
declare function lsight%(b%): ntx% = 7: sizey% = 30: sizex% = 60: shift = 49
Dim kbmatrix%(128), odd%(319)
Dim fmap%(sizex% - 1, sizey% - 1), wdis(319), testin%(ntx%, 63, 63), dsfc(319)
Dim cmap%(sizex% - 1, sizey% - 1), sb1%(159, 199), st(1800), ct(1800), hicol%(255)
Dim map%(sizex% - 1, sizey% - 1), tant(1800), xb%(1800), yb%(1800), sb2%(160 * 192 + 1)
Dim lowcol%(-128 To 127), bicol%(255), atx%(319), ammo%(2), oammo%(2), stt(1800), ctt(1800)
Call readmap: c% = nmeds% + nammo% - 1: ReDim med%(c%), scmed(c%), mx(c%), my(c%)
ReDim medis(c%), medx(c%), medy(c%), dis(nspr%), spord%(nspr%), disi%(nspr%)
ReDim sht(nshots%), shosht%(nshots%), shtx(nshots%), shty(nshots%), vshx(nshots%), vshy(nshots%)
ReDim shtang%(nshots%), shtdis(nshots%), dela%(nshots%), shtht%(nshots%), plasma%(nshots%)
ReDim bgh%(nbguysm1%), bgx(nbguysm1%), bgy(nbguysm1%), robo%(nbguysm1%)
ReDim x(nbguysm1%), y(nbguysm1%), vbx(nbguysm1%), vby(nbguysm1%)
ReDim scbg(nbguysm1%), bgang%(nbguysm1%), bgsht(nbguysm1%), lastx(nbguysm1%), lasty(nbguysm1%)
ReDim bgshosht%(nbguysm1%), bgshtx(nbguysm1%), bgshty(nbguysm1%)
ReDim bgvshx(nbguysm1%), bgvshy(nbguysm1%), bgshtdis(nbguysm1%)
ReDim bgdela%(nbguysm1%), bgshtht%(nbguysm1%), active%(nbguysm1%): _FullScreen: delta.t = .1
Call intro: maketables: makeworld: Get (0, 8)-(319, 199), sb2%()
main: raycast: keys: yourshot: time: yourmove: badguys: showhealth: medkit.etc
Call paintsprites: onscreen: endit: GoTo main
spritedata:
Data 0,6,2,1,0,4,""
'Map: each character (>"0") is a color or texture
'0 is empty space. Outer walls must not contain any 0's, ?'s, or r's
'1, 2, 3, 4, 5, 6, 7, 8, 9, :, ;, <, +, >, @, A are wall textures
'4 is the map, A is the rainbow
'? is an ice block "door"
'r is random: 50% chance of ice, else texture @
'. = empty, B = bad guy, R = robot, M = medkit, L = ammo, P = the President / player
mapdata:
Data "666666667546C66666666666666666666666666666666666666666666666"
Data "6.R..?.......6....M6L..................RR?................L6"
Data "6....1.......A.....?...................BB3................M6"
Data "6....1.......@.....6662?266666662526666666666664?766666666?6"
Data "6....1.......?.....6.....................6.................6"
Data "6....1.......>.....6.....................?.................6"
Data "6....1.......=.....6.....................6.................1"
Data "6....?.......<.....666666666444666666666?6.................1"
Data "6....2.......;.....6.........1...........6.......BBBB......1"
Data "6....2.......:.....6..BBBB...2......B....?.................6"
Data "6....2.......9.....6..BBBB...3...........6.................6"
Data "6....2.......8.....6.........4...........6.................6"
Data "6....?.......7.....6.........A777777777776666664?76666666666"
Data "6....3.......6.....6.......................................6"
Data "6....3.......5.....6.......................................6"
Data "6....3.......4.....7.......................................6"
Data "6....?.......3.....6.......................................6"
Data "6....4BBB....2..R..6.......................................6"
Data "6....4BBB....1LMMM612?45633?333333333333?33336.............6"
Data "6....4BBB....6657666.....6...................6.............6"
Data "6....4BBB....?.LLL.6.....6...................6.............6"
Data "6....4BBB....?.MMM.6.....6.......BBB.........?.............6"
Data "6....555555555555556.....r...................6.............6"
Data "6.........?.....M..6.....6...................6666666466666?6"
Data "6.........r........6.....6AAAAAAA?AAAAAAAAAA46.............3"
Data "6.........r........A.........................6.............4"
Data "6..B......r........A..BBBB...................?.............1"
Data "6.........r.....P..A.........................6...RRRR......2"
Data "6.........r.....L..A.............LLLLMMMM....6.............6"
Data "6155555555555556AAA66666666666666AAA666656666666666656666666"
Rem $STATIC
Function atan2 (y, x)
If x = 0 Then
If y > 0 Then atan2 = 90 Else If y < 0 Then atan2 = 270
ElseIf x > 0 Then
atan2 = (Atn(y / x) * 57.2958 + 360) Mod 360
Else
atan2 = (Atn(y / x) * 57.2958 + 180)
End If
End Function
Sub badguys
Shared nbguysm1%, testin%(), bgx(), bgy(), delta.t, bgh%(), dis()
Shared px, py, bx, by, vx, vy, fdt, scbg(), bgang%(), x(), y(), fram%, ph%
Shared bgsht(), bgshosht%(), bgvshx(), bgvshy(), ct(), st(), bgshtdis()
Shared inx%, iny%, map%(), fmap%(), bsa%, bgshtx(), bgshty(), bgdela%()
Shared bgshtht%(), nbguys%, vbx(), vby(), snd%, kills%, robo%(), active%(), lastx(), lasty()
For x% = 0 To nbguysm1%
testin%(4, Int(bgx(x%)) + 2, Int(bgy(x%)) + 19) = 0: Next
'bad guys: Note: I want to add some AI!
damp = .8 ^ fdt: sqrdt = Sqr(delta.t) * 6
For x% = 0 To nbguysm1%
If bgh%(x%) > 0 Then
If lsight%(x%) Then
active%(x%) = 1: lastx(x%) = bx: lasty(x%) = by
Else
If active%(x%) = 1 Then active%(x%) = 2
End If
bbgx = px - bgx(x%): bbgy = py - bgy(x%)
dis(x%) = Sqr(bbgx * bbgx + bbgy * bbgy) + .01
chase = 2 * delta.t * (1 + robo%(x%)) * -(active%(x%) > 0)
bbgx = lastx(x%) - bgx(x%): bbgy = lasty(x%) - bgy(x%)
cdis = Sqr(bbgx * bbgx + bbgy * bbgy) + .01
If active%(x%) = 2 And cdis < .3 Then active%(x%) = 0
vbx(x%) = vbx(x%) * damp + (Rnd - .5) * sqrdt + bbgx / cdis * chase
vby(x%) = vby(x%) * damp + (Rnd - .5) * sqrdt + bbgy / cdis * chase
If (px - bgx(x%)) ^ 2 + (py - bgy(x%)) ^ 2 < 1 Then
vbx(x%) = vbx(x%) - bbgx / dis(x%) * fdt
vby(x%) = vby(x%) - bbgy / dis(x%) * fdt
vx = vx + bbgx / dis(x%) * fdt
vy = vy + bbgy / dis(x%) * fdt
End If
'don't crowd bad guys
For y% = 0 To nbguysm1%
If x% <> y% And bgh%(y%) > 0 Then
bsdis = Sqr((bgy(x%) - bgy(y%)) ^ 2 + (bgx(x%) - bgx(y%)) ^ 2 + .01)
If bsdis < 1 Then
vbx(x%) = vbx(x%) - (bgx(y%) - bgx(x%)) / bsdis * fdt
vby(x%) = vby(x%) - (bgy(y%) - bgy(x%)) / bsdis * fdt
End If
End If: Next
svx% = Sgn(vbx(x%)): svy% = Sgn(vby(x%))
crashtest bgx(x%) + .15 * svx%, bgy(x%) + .15 * svy%, vbx(x%), vby(x%)
If map%(inx%, iny%) = 15 And active%(x%) = 0 Then active%(x%) = 3: icex = inx%: icey = iny%
crashtest bgx(x%) - .15 * svx%, bgy(x%) + .15 * svy%, vbx(x%), vby(x%)
If map%(inx%, iny%) = 15 And active%(x%) = 0 Then active%(x%) = 3: icex = inx%: icey = iny%
crashtest bgx(x%) + .15 * svx%, bgy(x%) - .15 * svy%, vbx(x%), vby(x%)
If map%(inx%, iny%) = 15 And active%(x%) = 0 Then active%(x%) = 3: icex = inx%: icey = iny%
bgx(x%) = bgx(x%) + vbx(x%) * delta.t: bgy(x%) = bgy(x%) + vby(x%) * delta.t
scbg(x%) = 2 / (dis(x%) + .01)
bgang%(x%) = atan2(bgy(x%) - by, bgx(x%) - bx) * 5
delba% = (bgang%(x%) - bsa% + 1800) Mod 1800
x(x%) = delba% - scbg(x%) * 20: y(x%) = 100 - 25 * scbg(x%)
'bad guy's shot
If bgsht(x%) <= 0 And active%(x%) = 1 Or active%(x%) = 3 Then
bgsht(x%) = 20 + Rnd: bgshosht%(x%) = 1: 'create shot
bgshtx(x%) = bgx(x%): bgshty(x%) = bgy(x%)
If active%(x%) = 3 Then active%(x%) = 0: bgang%(x%) = atan2(bgy(x%) - icey, bgx(x%) - icex) * 5
bgsta% = (bgang%(x%) + 900) Mod 1800
bgvshx(x%) = ct(bgsta%) * 7
bgvshy(x%) = st(bgsta%) * 7
'test if other bad guys are blocking the shot; if so don't shoot
tbsx = bgx(x%): tbsy = bgy(x%): tbsvx = bgvshx(x%): tbsvy = bgvshy(x%)
Do: tbsx = tbsx + tbsvx * delta.t: tbsy = tbsy + tbsvy * delta.t
crashtest tbsx, tbsy, tbsvx, tbsvy: k% = map%(inx%, iny%)
For y% = 0 To nbguysm1%
If x% <> y% And bgh%(y%) > 0 Then
bsdis = Sqr((tbsy - bgy(y%)) ^ 2 + (tbsx - bgx(y%)) ^ 2 + .01)
If bsdis < .5 Then k% = -1
End If: Next
bsdis = Sqr((tbsy - by) ^ 2 + (tbsx - bx) ^ 2 + .01)
If bsdis < .5 Then k% = -2
Loop Until k%
If k% = -1 Then bgsht(x%) = 0: bgshosht%(x%) = 0
End If
End If
'bad guy's shot
If bgsht(x%) > 0 And bgshosht%(x%) Then
crashtest bgshtx(x%), bgshty(x%), bgvshx(x%), bgvshy(x%)
k% = map%(inx%, iny%)
If k% Then
bgshosht%(x%) = 0
If k% = 15 And bgsht(x%) > 0 Then
map%(inx%, iny%) = 0
testin%(4, inx% + 2, iny% + 19) = 0
End If
Else
bgshtx(x%) = bgshtx(x%) + bgvshx(x%) * delta.t
bgshty(x%) = bgshty(x%) + bgvshy(x%) * delta.t
bbx = bgshtx(x%) - bx: bby = bgshty(x%) - by
bgshtang% = atan2(bby, bbx) * 5
bgshtdis(x%) = Sqr(bby * bby + bbx * bbx + .01)
dis(x% + nbguys%) = bgshtdis(x%)
'fix damage test
If bgshtdis(x%) < .5 Then
ph% = ph% - bgsht(x%) / 4 - 2.5 * (1 + robo%(x%)): bgshosht%(x%) = 0
If snd% Then Sound 150, 1
vx = vx + bgvshx(x%) * .05: vy = vy + bgvshy(x%) * .05
End If
'kill each other?
For y% = 0 To nbguysm1%
If x% <> y% And bgh%(y%) > 0 Then
bsdis = Sqr((bgshty(x%) - bgy(y%)) ^ 2 + (bgshtx(x%) - bgx(y%)) ^ 2 + .01)
If bsdis < .5 Then
bgh%(y%) = bgh%(y%) - bgsht(x%) / 2 - 1: bgshosht%(x%) = 0
vbx(y%) = vbx(y%) + bgvshx(x%) * .5: vby(y%) = vby(y%) + bgvshy(x%) * .5
If bgh%(y%) < 1 Then
fmap%(Int(bgx(y%)), Int(bgy(y%))) = 4 + 4 * robo%(y%)
kills% = kills% + 1: Exit For
End If
End If
End If: Next
bgdela%(x%) = (bgshtang% - bsa% + 1800) Mod 1800
bgshtht%(x%) = 30 / bgshtdis(x%)
End If
End If
If bgsht(x%) > 0 Then bgsht(x%) = bgsht(x%) - fdt
If fram% / 2 = fram% \ 2 Then
testin%(4, Int(px) + 2, Int(py) + 19) = 1
If bgh%(x%) > 0 Then testin%(4, Int(bgx(x%)) + 2, Int(bgy(x%)) + 19) = 4 + 4 * robo%(x%)
End If
Next x%
End Sub
Sub crashtest (bx, by, vx, vy): 'note vx & vy args must be byref
Shared map%(), delta.t, inx%, iny%
Static oinx%, oiny%, nallcl%, chn2%, xsign%, ysign%, k%, kx%, ky%
oinx% = Int(bx): oiny% = Int(by): nallcl% = 1
px = bx + vx * delta.t: py = by + vy * delta.t
inx% = Int(px): iny% = Int(py)
ysign% = Sgn(vy): xsign% = Sgn(vx)
chn2% = (inx% - oinx%) * xsign% + (iny% - oiny%) * ysign%
k% = map%(inx%, iny%)
If inx% = oinx% Then horz% = 1
If iny% = oiny% Then vert% = 1
If chn2% = 2 Then
ys% = (1 + ysign%) \ 2: xs% = (1 + xsign%) \ 2
kx% = map%(oinx%, iny%): ky% = map%(inx%, oiny%)
tstang% = Sgn((px - bx) * (iny% + 1 - ys% - by) - (py - by) * (inx% + 1 - xs% - bx))
tst% = xsign% * ysign% * tstang%
If tst% = 1 And k% + ky% = 0 Then nallcl% = 0
If tst% = -1 And k% + kx% = 0 Then nallcl% = 0
If ky% = 0 Then
horz% = 1
Else
vert% = 1: k% = ky%: If tst% = 1 Then iny% = oiny%
End If
If kx% Then
horz% = 1: k% = kx%: If tst% = -1 Then inx% = oinx%
Else
vert% = 1
End If
End If: If k% = 0 Then nallcl% = 0
If nallcl% Then
If horz% And vert% And ky% = 0 And kx% = 0 Then
If tst% = 1 Then horz% = 0 Else vert% = 0
End If
If vert% Then vx = 0
If horz% Then vy = 0
End If
End Sub
Function lsight% (b%)
Shared map%(), delta.t, inx%, iny%, px, py, bgx(), bgy()
delx = bgx(b%) - px: dely = bgy(b%) - py: delmag = Sqr(delx ^ 2 + dely ^ 2)
lx = px: ly = py: delx = delx / delmag / delta.t: dely = dely / delmag / delta.t: lt% = 0
Do: crashtest lx, ly, delx, dely: lx = lx + delx * delta.t: ly = ly + dely * delta.t
lt% = lt% + 1
Loop Until map%(inx%, iny%) Or lt% >= delmag
lsight% = (map%(inx%, iny%) = 0)
End Function
Sub endit
Shared kills%, nbguysm1%, nbguys%, kbmatrix%(), goon%, ph%, bgh%(), snd%
If kbmatrix%(1) - 1 And ph% > 0 And kills% < nbguys% Then
goon% = 2
Else
goon% = goon% - 1
End If
If goon% = 0 Then
Locate 2, 1:
If kills% = nbguys% And ph% > 0 Then
Print "President Snore, you made it!": If snd% Then Play "mf gcfde"
Else
Print "You die"
For t% = 400 To 200 Step -20
If snd% Then Sound t%, 1
tim = Timer: Do: Loop Until Timer > tim
Next
End If
tim = Timer + .5: Do: Loop Until Timer > tim
Sleep 1: End
End If
End Sub
Sub hLINE (x1%, x2%, y%, c%)
Shared sb1%(), hicol%(): ccc% = hicol%(c%) + c%
If x1% < 0 Then x1% = 0
If x2% > 319 Then x2% = 319
For x% = Int(x1% / 2) To Int(x2% / 2)
sb1%(x%, y%) = ccc%
Next
End Sub
Sub intro: Shared snd%, nbguys%, nrobo%
Cls: Print "By Dr. Jacques Mallah", , "Assassins Edition.64"
Print: Print "In the year 3001 AD:"
Print "You, President Sal Snore of the United Snows of Antarctica,"
Print "are trapped in the Wight House with a bunch of guys trying to kill you. "
Print "They also reprogrammed your robot bodyguard(s).": Print
Print "Luckily, you have your trusty plasma gun (press 1) and machine gun (press 2)"
Print "and plas-cannon (press 3; uses plasma gun ammo)."
Print "Hiding's not your style. You'll show them who's the boss!"
Print "Kill 'em all to win. ("; nbguys% - nrobo%; " guy(s) and "; nrobo%; " robot(s))": Print
Print "use arrow forward, back to move; use arrow left, right to rotate"
Print "Alt to strafe with arrow left, right"
Print "Ctrl to shoot"
Print "To fight, try getting some distance and using strafe"
Print "Try shooting out some ice blocks"
Print "pick up ";: Color 0, 2: Print "-";: Color 7, 0: Print " ammo, and ";
Color 4, 15: Print "+";: Color 7, 0: Print " medical kits when needed"
Print "After starting, press Esc to take the easy way out - suicide!"
Print "press any key to start, SPACE for no sound": Print
Print "The # at the top left corner is frames per second"
Print "The bar at the bottom is your health."
Print "j to toggle cheat mode";
i$ = Input$(1): If i$ <> " " Then snd% = 1
End Sub
Sub maketables
Shared st(), ct(), dsfc(), hicol%(), lowcol%(), bicol%(), atx%(), tant()
Shared xb%(), yb%(), spord%(), nspr%, stt(), ctt()
For tmp1% = 0 To 1800
st(tmp1%) = Sin(tmp1% * Atn(1) / 225): stt(tmp1%) = st(tmp1%) * 256
ct(tmp1%) = Cos(tmp1% * Atn(1) / 225): ctt(tmp1%) = ct(tmp1%) * 256
Next tmp1%
st(0) = 10 ^ -9: st(900) = 10 ^ -9: st(1800) = st(0)
stt(0) = 10 ^ -7: stt(900) = 10 ^ -7
ct(450) = 10 ^ -9: ct(1350) = 10 ^ -9
ctt(450) = 10 ^ -7: ctt(1350) = 10 ^ -7
For t% = 0 To 1800
sqct = Abs(1 / ct(t%)): sqt = Abs(1 / st(t%))
If sqt > sqct Then nn = sqct * 255 Else nn = sqt * 255
xb%(t%) = ct(t%) * nn: yb%(t%) = st(t%) * nn
tant(t%) = st(t%) / ct(t%): Next
yb%(0) = 0: yb%(900) = 0
xb%(450) = 0: xb%(1350) = 0
For x% = 0 To 319
atx%(x%) = Atn((x% - 160) * 3.14159 / 900) * 900 / 3.14159
dsfc(x%) = 100 / Abs(ct((atx%(x%) + 1800) Mod 1800))
Next
For c% = 0 To 255
hicol%(c%) = &H100 * (c% + &H100 * (c% > &H7F))
lowcol%(c% - 128) = c% - 128 - &H100 * ((c% - 128) < 0)
bicol%(c%) = &H100 * (c% + &H100 * (c% > &H7F)) + c%
Next
For x% = 0 To nspr%: spord%(x%) = x%: Next
End Sub
Sub readmap
Shared fmap%(), sizex%, sizey%, testin%(), hicol%(), cmap%(), map%(), ntx%
Shared ph%, nbguysm1%, bgh%(), bgy(), bgx(), oldtim, nmeds%, medx(), medy()
Shared nshots%, med%(), ammo%(), weap$, px, py, sa, nmeds%, nammo%, robo%()
Shared maxshots%, nbguys%, nshots%, nspr%, nbguyst2%, nrobo%
Shared scmed(), mx(), my(), medis()
Shared F0%, F1%, F2%, F3%, F4%, F5%, bg$
DefInt N
Randomize Timer: nmeds% = 0: nammo% = 0: px = 17.5: py = 27.5: sa = 1190
Read F0%, F1%, F2%, F3%, F4%, F5%, bg$: nb = 0
For y = 0 To sizey% - 1: Read i$: For x = 0 To sizex% - 1
ii$ = Mid$(i$, x + 1, 1): map%(x, y) = Asc(ii$) - 48
If ii$ = "." Then map%(x, y) = 0
If ii$ = "B" Or ii$ = "R" Then nb = nb + 1: If ii$ = "R" Then nrobo% = nrobo% + 1
If map%(x, y) = 66 Then map%(x, y) = 16 + (Rnd < .5)
If map%(x, y) < 0 Then map%(x, y) = map%(x, y) + 256
If y = 0 Or x = 0 Or y = sizey% - 1 Or x = sizex% - 1 Then
If map%(x, y) = 0 Then map%(x, y) = 14
If map%(x, y) = 15 Then map%(x, y) = 14
End If
If ii$ = "M" Then nmeds% = nmeds% + 1
If ii$ = "L" Then nammo% = nammo% + 1
If ii$ = "P" Then px = x + .5: py = y + .5: map%(x, y) = 0
Next: Next
maxshots% = 9: nbguys% = nb: nbguysm1% = nbguys% - 1: nbguyst2% = nbguys% * 2
nshots% = maxshots%: nspr% = maxshots% + nbguyst2% + nmeds% + nammo%
End Sub
Sub makeworld
Shared fmap%(), sizex%, sizey%, testin%(), hicol%(), cmap%(), map%(), ntx%
Shared ph%, nbguysm1%, bgh%(), bgy(), bgx(), oldtim, nmeds%, medx(), medy()
Shared nshots%, med%(), ammo%(), weap$, px, py, sa, nmeds%, nammo%, robo%()
Shared maxshots%, nbguys%, nshots%, nspr%, snd%
Shared scmed(), mx(), my(), medis()
Shared F0%, F1%, F2%, F3%, F4%, F5%, bg$
DefInt N, T, X-Y
Screen 13: nb = 0: nm = 0: nam = nmeds%: If snd% Then Play "mb"
nshots% = 1: weap$ = " plasma gun": ammo%(0) = 24: ammo%(1) = 200
For y = 1 To sizey% - 2: For x = 1 To sizex% - 2
If map%(x, y) = 18 Then map%(x, y) = 0: bgx(nb) = x + .5: bgy(nb) = y + .5: nb = nb + 1
If map%(x, y) = 34 Then
map%(x, y) = 0: bgx(nb) = x + .5: bgy(nb) = y + .5: robo%(nb) = 1: nb = nb + 1
End If
If map%(x, y) = Asc("M") - 48 Then
medx(nm) = x + .5: medy(nm) = y + .5: map%(x, y) = 0: med%(nm) = 1: nm = nm + 1 'meds
End If
If map%(x, y) = Asc("L") - 48 Then
medx(nam) = x + .5: medy(nam) = y + .5: map%(x, y) = 0: med%(nam) = 1: nam = nam + 1 'ammo
End If
Next: Next
For t = 0 To ntx%: For x = 0 To 63: For y = 0 To 63
testin%(t, x, y) = (t * 14 + Sqr((x - 32) ^ 2 + (y - 32 - Rnd * t) ^ 2)) Mod 256
testin%(t, x, y) = testin%(t, x, y) + hicol%(t + 1 + (Rnd < .1))
Next: Next: Next
For x = 2 To 61: For y = 19 To 48
testin%(4, x, y) = map%(x - 2, y - 19): Next: Next
For x = 0 To 59: For y = 0 To 29: fmap%(x, y) = ((x + y) Mod 16) + 128
If map%(x, y) = 15 Then fmap%(x, y) = 15
Next: Next: For x = 16 To 18: For y = 26 To 28
fmap%(x, y) = 208: Next: Next
fmap%(39, 15) = -7: fmap%(24, 10) = -2: fmap%(17, 25) = 0
For x = 20 To 35: fmap%(x, 25) = 20 - x: Next
For x = 0 To 59: For y = 0 To 29: cmap%(x, y) = 26
If x / 2 = x \ 2 Or y / 2 = y \ 2 Then cmap%(x, y) = 27
If x / 2 = x \ 2 And y / 2 = y \ 2 Then cmap%(x, y) = 15
Next: Next: For x = 16 To 18: For y = 26 To 28
cmap%(x, y) = 208: Next: Next: cmap%(17, 27) = 15
Color 16: Print "Abandon": Print "all dope"
Print "Your ad": Print " here:": Print " $100": Print " Call"
Print " 1-800-": Print " EATS": Print " ???": Print " QB 64"
Print " I $": Print: Print " Wight": Print " House": Print " HIT"
Print: Print " Who's": Print "da man?": Print " Please": Print "recycle"
Print " JM": For x = 0 To 63: For y = 0 To 15
If Point(x, y) Then testin%(1, x, y + 1) = 15
If Point(x, y + 16) Then testin%(5, x, y + 8) = 0
If Point(x, y + 32) Then testin%(5, x, y + 24) = 0
If Point(x, y + 48) Then testin%(5, x, y + 40) = 0
If Point(x, y + 64) Then testin%(6, x, y + 32) = 7
If Point(x, y + 80) Then testin%(2, x, y + 1) = 4
If Point(x, y + 96) Then testin%(4, x, y + 1) = 15
If Point(x, y + 112) And y < 8 Then testin%(5, x, y + 56) = 0
If Point(x, y + 128) Then testin%(3, x, y + 48) = 1
If Point(x, y + 144) Then testin%(0, x, y + 48) = 6
If Point(x, y + 160) Then testin%(7, x, y + 32) = 9
Next: Next: Color 15
For x = 0 To 63: For y = 0 To 63
t = 15: If (Rnd * 60 > y) Then t = 24 + Rnd * 6
testin%(7, x, y) = (testin%(7, x, y) And &HFF) + hicol%(t)
Next: Next
ph% = 100: For x% = 0 To nbguysm1%: bgh%(x%) = 100: If robo%(x%) Then bgh%(x%) = 1250
If bgx(x%) = 0 Then
randloc:
bgx(x%) = Int(Rnd * (sizex% - 1) + 1) + .5
bgy(x%) = Int(Rnd * (sizey% - 1) + 1) + .5
If map%(Int(bgx(x%)), Int(bgy(x%))) GoTo randloc
End If
Next: oldtim = Timer
End Sub
DefSng T, X-Y
Sub medkit.etc: 'medkits and ammo boxes
Shared nmeds%, medis(), nbguyst2%, maxshots%, medx(), medy(), scmed(), dis()
Shared mx(), my(), ph%, bx, by, bgx(), bgy(), bgh%(), med%(), nbguysm1%, bsa%
Shared ammo%(), nammo%, robo%()
For x% = 0 To nmeds% + nammo% - 1
If med%(x%) Then
medis(x%) = Sqr((bx - medx(x%)) ^ 2 + (by - medy(x%)) ^ 2)
dis(x% + nbguyst2% + maxshots% + 1) = medis(x%)
scmed(x%) = 3 / (dis(x% + nbguyst2% + maxshots% + 1) + .01)
bgang% = atan2(medy(x%) - by, medx(x%) - bx) * 5
delba% = (bgang% - bsa% + 1800) Mod 1800
mx(x%) = delba% - scmed(x%) * 10: my(x%) = 100 + 15 * scmed(x%)
If medis(x%) < .36 Then
If x% < nmeds% And ph% < 95 Then
med%(x%) = 0: ph% = ph% + 35: If ph% > 98 Then ph% = 98
End If
If x% >= nmeds% Then
med%(x%) = 0: ammo%(0) = ammo%(0) + 16: ammo%(1) = ammo%(1) + 100
End If
End If
For y% = 0 To nbguysm1%
If bgh%(y%) > 0 And robo%(y%) = 0 Then
bsdis = (bgx(y%) - medx(x%)) * (bgx(y%) - medx(x%)) + (bgy(y%) - medy(x%)) * (bgy(y%) - medy(x%))
If med%(x%) And bsdis < .6 And bgh%(y%) < 95 And y% <> 8 And x% < nmeds% Then
med%(x%) = 0: bgh%(y%) = bgh%(y%) + 35: If bgh%(y%) > 98 Then bgh%(y%) = 98
End If
End If: Next
End If: Next
End Sub
Sub onscreen
Shared bitex%, fire, sb1%(), mg%, omg%, weap$, ammo%(), oammo%(), sb2%()
Shared kills%, okills%, oofram%, ofram%
bitex% = 1: t% = (fire > 0) * 15: hLINE 155, 166, 100, -t%
vline 160, 96, 104, 15 + t%: bitex% = 0
'draw on screen
Wait &H3DA, 8: 'wait for screen refresh
For x% = 0 To 159: For y% = 8 To 199
sb2%(2 + x% + 160 * (y% - 8)) = sb1%(x%, y%)
Next: Next
Put (0, 8), sb2%(), PSet
If mg% <> omg% Or kills% > okills% Or ammo%(mg% And 1) <> oammo%(mg% And 1) Then
Locate 1, 10: Print weap$;
Print Using " ####"; ammo%(mg% And 1);
Print Using " ammo ### "; kills%;: Print "kill";
If kills% <> 1 Then Print "s"; Else Print " ";
omg% = mg%: okills% = kills%: oammo%(mg% And 1) = ammo%(mg% And 1)
End If
If oofram% <> ofram% Then
Locate 1, 1: Print Using "### fps"; ofram%;: oofram% = ofram%
End If
End Sub
Sub paintsprites
Shared nspr%, spord%(), dis(), nbguyst2%, nbguys%, maxshots%, disi%()
'This uses the painter's algorithm with an exchange sort to show sprites
For x% = 0 To nspr%: disi%(spord%(x%)) = dis(spord%(x%)) * 512: Next
For x% = 0 To nspr% - 1: For y% = x% + 1 To nspr%
If disi%(spord%(y%)) > disi%(spord%(x%)) Then Swap spord%(x%), spord%(y%)
Next: Next: For xx% = 0 To nspr%
If spord%(xx%) < nbguys% Then
showbadguy spord%(xx%)
ElseIf spord%(xx%) < nbguyst2% Then
showbadshot spord%(xx%) - nbguys%
ElseIf spord%(xx%) < nbguyst2% + maxshots% + 1 Then
showurshot spord%(xx%) - nbguyst2%
Else
showmed spord%(xx%) - nbguyst2% - maxshots% - 1
End If: Next xx%
End Sub
Sub putbox (x1, y1%, x2, y2%, col%, boxdis)
Shared wdis()
For x% = x1 To x2
If x% >= 0 And x% < 320 Then
If boxdis < wdis(x%) Then vline x%, y1%, y2%, col%
End If
Next
End Sub
Sub putcircle (x%, y%, R%, col%, circdis)
Shared wdis()
xb% = x% - R% + 1: xt% = x% + R% - 1
If xb% > -1 And xb% < 320 Then
If circdis < wdis(xb%) Then showc% = 1
End If
If xt% > -1 And xt% < 320 Then
If circdis < wdis(xt%) Then showc% = showc% + 1
End If
If showc% = 1 Then
For xx% = xb% To xt%
If xx% > -1 And xx% < 320 Then
If circdis < wdis(xx%) Then
shthtx% = R% * Sqr(1 - (xx% - x%) * (xx% - x%) / R% / R%) * .8
vline xx%, y% - shthtx%, y% + shthtx%, col%
End If
End If
Next
ElseIf showc% = 2 Then
For xx% = xb% To xt%
shthtx% = R% * Sqr(1 - (xx% - x%) * (xx% - x%) / R% / R%) * .8
vline xx%, y% - shthtx%, y% + shthtx%, col%
Next
End If
End Sub
Sub raycast
Shared wdis(), odd%(), st(), ct(), dsfc(), atx%(), hicol%(), testin%()
Shared map%(), fmap%(), cmap%(), bicol%(), sb1%(), ntx%, gm%, xb%(), yb%()
Shared sizex%, sizey%, lowcol%(), bx, by, efa%, px, py, bsa%, sa, stt(), ctt()
bx = px: by = py: efa% = (sa + 1960) Mod 1800: bsa% = sa
bxx% = bx * 256: byy% = by * 256: TIMR = Timer * 10: nttx% = 2 * ntx% + 1
sizexf% = sizex% * 256: sizeyf% = sizey% * 256
For x% = 0 To 319
t% = (efa% + atx%(x%) + 1800) Mod 1800: xx% = x% \ 2
If xx% = x% \ 2 Then
rxx% = bxx%: ryy% = byy%: oinx% = rxx% \ 256: oiny% = ryy% \ 256
inx% = oinx%: iny% = oiny%: ysign% = Sgn(yb%(t%)): xsign% = Sgn(xb%(t%))
ys% = (1 - ysign%) \ 2: xs% = (1 - xsign%) \ 2
yss& = ys% * 256 - byy%: xss& = xs% * 256 - bxx%
'find dis & col
oldi: Do: rxx% = rxx% + xb%(t%): ryy% = ryy% + yb%(t%)
oinx% = inx%: oiny% = iny%
inx% = rxx% \ &H100: iny% = ryy% \ &H100
k% = map%(inx%, iny%)
chn2% = (inx% - oinx%) * xsign% + (iny% - oiny%) * ysign%
Loop Until chn2% = 2 Or k%
If chn2% = 2 Then
kx% = map%(oinx%, iny%)
ky% = map%(inx%, oiny%)
If k% + kx% + ky% = 0 GoTo oldi
tst% = xsign% * ysign% * Sgn((rxx% - bxx%) * (iny% * 256 + yss&) - (ryy% - byy%) * (inx% * 256 + xss&))
If (tst% = 1 And k% + ky% = 0) Or (tst% <= 0 And k% + kx% = 0) GoTo oldi
End If
horz% = 0: If inx% = (rxx% - xb%(t%)) \ &H100 Then horz% = chn2% And 1
If chn2% = 2 Then
If tst% > 0 Then
If ky% Then k% = ky%: iny% = oiny% Else horz% = 1
Else
If kx% Then horz% = 1: k% = kx%: inx% = oinx%
End If
End If
End If
If horz% Then
wdis(x%) = (iny% * 256 + yss&) / stt(t%)
If t% > 1780 Or t% < 20 Or (t% > 880 And t% < 920) Then
dis = (inx% * 256 + xss&) / ctt(t%): If dis > wdis(x%) Then wdis(x%) = dis
End If
xfrac = bx + wdis(x%) * ct(t%)
bcc% = Int((xfrac - Int(xfrac)) * 63.9): If ys% = 0 Then bcc% = 63 - bcc%
Else
wdis(x%) = (inx% * 256 + xss&) / ctt(t%)
If (t% > 1330 And t% < 1370) Or (t% > 430 And t% < 470) Then
dis = (iny% * 256 + yss&) / stt(t%): If dis > wdis(x%) Then wdis(x%) = dis
End If
xfrac = by + wdis(x%) * st(t%)
bcc% = Int((xfrac - Int(xfrac)) * 63.9): If xs% Then bcc% = 63 - bcc%
End If
dd% = dsfc(x%) / wdis(x%): odd%(x%) = dd%
'load view to buffer
If x% And 1 Then
afx% = ctt(t%) * dsfc(x%): afy% = stt(t%) * dsfc(x%): yt% = dd% + 1
fixfloor:
If yt% < 92 Then
fcxp% = (bxx% + afx% \ yt%): fcyp% = (byy% + afy% \ yt%)
If fcxp% <= 0 Or fcyp% <= 0 Or fcxp% >= sizexf% Or fcyp% >= sizeyf% Then
sb1%(xx%, yt% + 99) = 0: sb1%(xx%, 100 - yt%) = 0: yt% = yt% + 1: GoTo fixfloor
End If
End If
For y% = yt% To 92
fcxp% = (bxx% + afx% \ y%): fcx% = fcxp% \ &H100
fcyp% = (byy% + afy% \ y%): fcy% = fcyp% \ &H100
flor% = fmap%(fcx%, fcy%)
If flor% > 0 Then
sb1%(xx%, y% + 99) = bicol%(flor%)
ElseIf flor% >= -ntx% Then
sb1%(xx%, y% + 99) = (testin%(-flor%, (fcxp% \ 4) And &H3F, (fcyp% \ 4) And &H3F) And &HFF) + hicol%(testin%(-flor%, (fcxp% \ 4) And &H3F, (fcyp% \ 4) And &H3F) And &HFF)
Else
flor% = -flor% - ntx% - 1
fcxp% = (fcxp% \ 4) And &H3F: fcyp% = (fcyp% \ 4) And &H3F
tst% = (testin%(flor%, fcxp%, fcyp%) And &HFF00)
sb1%(xx%, y% + 99) = lowcol%((testin%(flor%, fcxp%, fcyp%) And &HFF00) \ 256) + tst%
End If
sb1%(xx%, 100 - y%) = bicol%(cmap%(fcx%, fcy%))
Next
End If
If k% = nttx% + 1 Then k% = 0
If k% > nttx% Then
kx% = k%: If k% = 17 Then kx% = Int(TIMR + xfrac * 40) And &HFF
yb% = 99 + dd%: If yb% > 191 Then yb% = 191
yt% = 100 - dd%: If yt% < 8 Then yt% = 8
If x% And 1 Then
For y% = yt% To yb%: sb1%(xx%, y%) = (sb1%(xx%, y%) And &HFF) + hicol%(kx%): Next
Else
For y% = yt% To yb%: sb1%(xx%, y%) = (sb1%(xx%, y%) And &HFF00) + kx%: Next
End If
ElseIf x% And 1 Then
If dd% > 31 Then
hmd% = 100 - dd%: df% = (dd% + 4) \ 32: dof& = dd%: kx% = k% - ntx% - 1
For yfrac% = 0 To 63: yt% = hmd% + (yfrac% * dof&) \ &H20: yb% = yt% + df%
If yt% < 8 Then yt% = 8
If yb% > &HBF Then yb% = &HBF
If k% <= ntx% Then
tst% = hicol%(testin%(k%, bcc%, yfrac%) And &HFF) + (testin%(k%, obcc%, yfrac%) And &HFF)
Else
tst% = (testin%(kx%, bcc%, yfrac%) And &HFF00) + lowcol%((testin%(kx%, obcc%, yfrac%) And &HFF00) \ 256)
End If
For y% = yt% To yb%: sb1%(xx%, y%) = tst%: Next: Next
Else
yb% = 2 * dd% - 1: hmd% = 100 - dd%
If k% <= ntx% Then
For y% = hmd% To 99 + dd%: yfrac% = ((y% - hmd%) * 63) \ yb%
sb1%(xx%, y%) = hicol%(testin%(k%, bcc%, yfrac%) And &HFF) + (testin%(k%, obcc%, yfrac%) And &HFF)
Next
Else
kx% = k% - ntx% - 1
For y% = hmd% To 99 + dd%: yfrac% = ((y% - hmd%) * 63) \ yb%
sb1%(xx%, y%) = (testin%(kx%, bcc%, yfrac%) And &HFF00) + lowcol%((testin%(kx%, obcc%, yfrac%) And &HFF00) \ 256)
Next
End If
End If
End If
obcc% = bcc%: Next
End Sub
Sub showbadguy (b%)
Shared bgh%(), scbg(), x(), y(), dis(), F0%, F1%, F2%, F3%, F4%, F5%, wdis(), robo%(), active%()
If bgh%(b%) > 0 Then
If x(b%) >= 0 And x(b%) <= 319 Then
If dis(b%) < wdis(x(b%)) Then showb% = 1: 'active%(b%) = 1
End If
xt% = x(b%) + scbg(b%) * 40
If xt% >= 0 And xt% < 320 Then
If dis(b%) < wdis(xt%) Then showb% = 1: 'active%(b%) = 1
End If
If showb% Then
If robo%(b%) Then F1% = 7
putbox x(b%) + scbg(b%) * 16, y(b%) + 0, x(b%) + scbg(b%) * 24, y(b%) + scbg(b%) * 2, F0%, dis(b%)
putbox x(b%) + scbg(b%) * 15, y(b%) + scbg(b%) * 2, x(b%) + scbg(b%) * 25, y(b%) + scbg(b%) * 10, F1%, dis(b%)
putbox x(b%) + scbg(b%) * 10, y(b%) + scbg(b%) * 10, x(b%) + scbg(b%) * 30, y(b%) + scbg(b%) * 40, b%, dis(b%)
putbox x(b%), y(b%) + scbg(b%) * 11, x(b%) + scbg(b%) * 10, y(b%) + scbg(b%) * 20, b%, dis(b%)
putbox x(b%) + scbg(b%) * 30, y(b%) + scbg(b%) * 11, x(b%) + scbg(b%) * 40, y(b%) + scbg(b%) * 20, b%, dis(b%)
putbox x(b%), y(b%) + scbg(b%) * 20, x(b%) + scbg(b%) * 5, y(b%) + scbg(b%) * 40, b%, dis(b%)
putbox x(b%) + scbg(b%) * 35, y(b%) + scbg(b%) * 20, x(b%) + scbg(b%) * 40, y(b%) + scbg(b%) * 40, b%, dis(b%)
putbox x(b%) + scbg(b%) * 10, y(b%) + scbg(b%) * 40, x(b%) + scbg(b%) * 18, y(b%) + scbg(b%) * 70, F3%, dis(b%)
putbox x(b%) + scbg(b%) * 22, y(b%) + scbg(b%) * 40, x(b%) + scbg(b%) * 30, y(b%) + scbg(b%) * 70, F3%, dis(b%)
putbox x(b%) + scbg(b%) * 18, y(b%) + scbg(b%) * 40, x(b%) + scbg(b%) * 22, y(b%) + scbg(b%) * 50, F3%, dis(b%)
putbox x(b%) + scbg(b%) * 7, y(b%) + scbg(b%) * 70, x(b%) + scbg(b%) * 18, y(b%) + scbg(b%) * 75, F4%, dis(b%)
putbox x(b%) + scbg(b%) * 22, y(b%) + scbg(b%) * 70, x(b%) + scbg(b%) * 33, y(b%) + scbg(b%) * 75, F4%, dis(b%)
putbox x(b%) + scbg(b%) * 5, y(b%) + scbg(b%) * 35, x(b%) + scbg(b%) * 15, y(b%) + scbg(b%) * 40, F1%, dis(b%)
putbox x(b%) + scbg(b%) * 25, y(b%) + scbg(b%) * 35, x(b%) + scbg(b%) * 35, y(b%) + scbg(b%) * 40, F1%, dis(b%)
putbox x(b%) + scbg(b%) * 15, y(b%) + scbg(b%) * 25, x(b%) + scbg(b%) * 25, y(b%) + scbg(b%) * 35, F5%, dis(b%)
putbox x(b%) + scbg(b%) * 16, y(b%) + scbg(b%) * 3, x(b%) + scbg(b%) * 18, y(b%) + scbg(b%) * 4, 0, dis(b%)
putbox x(b%) + scbg(b%) * 22, y(b%) + scbg(b%) * 3, x(b%) + scbg(b%) * 24, y(b%) + scbg(b%) * 4, 0, dis(b%)
putbox x(b%) + scbg(b%) * 16, y(b%) + scbg(b%) * 4, x(b%) + scbg(b%) * 18, y(b%) + scbg(b%) * 4, 7, dis(b%)
putbox x(b%) + scbg(b%) * 22, y(b%) + scbg(b%) * 4, x(b%) + scbg(b%) * 24, y(b%) + scbg(b%) * 4, 7, dis(b%)
putbox x(b%) + scbg(b%) * 17, y(b%) + scbg(b%) * 4, x(b%) + scbg(b%) * 17, y(b%) + scbg(b%) * 4, 0, dis(b%)
putbox x(b%) + scbg(b%) * 23, y(b%) + scbg(b%) * 4, x(b%) + scbg(b%) * 23, y(b%) + scbg(b%) * 4, 0, dis(b%)
putbox x(b%) + scbg(b%) * 20, y(b%) + scbg(b%) * 5, x(b%) + scbg(b%) * 20, y(b%) + scbg(b%) * 6, 114, dis(b%)
putbox x(b%) + scbg(b%) * 18, y(b%) + scbg(b%) * 8, x(b%) + scbg(b%) * 22, y(b%) + scbg(b%) * 8, 4, dis(b%)
F1% = 6
End If
End If
End Sub
Sub showbadshot (x%)
Shared bgsht(), bgshosht%(), bgdela%(), bgshtht%(), bgshtdis(), robo%()
If bgsht(x%) > 0 And bgshosht%(x%) Then
putcircle bgdela%(x%), 100, bgshtht%(x%), 4 + robo%(x%), bgshtdis(x%)
End If
End Sub
Sub showhealth
Shared gm%, ogm%, ph%, oph%
If gm% Then ph% = 100
If ph% - oph% Or gm% - ogm% Then
For y% = 194 To 199
hLINE 0, 319 * ph% / 100, y%, 1 + 14 * gm%
hLINE 319 * ph% / 100 + 1, 319, y%, 4
Next: ogm% = gm%: oph% = ph%
End If
End Sub
Sub showmed (b%)
Shared med%(), scmed(), mx(), my(), medis(), nmeds%
' Print b%, nmeds%
If med%(b%) Then
c% = (b% < nmeds%)
putbox mx(b%) + 0, my(b%) + 0, mx(b%) + scmed(b%) * 20, my(b%) + scmed(b%) * 20, 2 - 13 * c%, medis(b%)
putbox mx(b%) + scmed(b%) * 8, my(b%) + scmed(b%) * 3, mx(b%) + scmed(b%) * 13, my(b%) + scmed(b%) * 17, 2 - 2 * c%, medis(b%)
putbox mx(b%) + scmed(b%) * 3, my(b%) + scmed(b%) * 8, mx(b%) + scmed(b%) * 17, my(b%) + scmed(b%) * 13, -4 * c%, medis(b%)
End If
End Sub
Sub showurshot (x%)
Shared mg%, fb%, sht(), shosht%(), dela%(), shtdis(), shtht%(), plasma%()
If plasma%(x%) = 0 And sht(x%) > 0 And shosht%(x%) Then putcircle dela%(x%), 100 + 30 / shtdis(x%), shtht%(x%) / 3 + 1, 0, shtdis(x%)
If plasma%(x%) = 1 And sht(x%) > 0 And shosht%(x%) Then putcircle dela%(x%), 100 + 10 / shtdis(x%), shtht%(x%) * 1.5, 13, shtdis(x%)
End Sub
Sub time
Shared ofram%, delta.t, fdt, kbmatrix%(), gm%, fram%
Static oldtimer&, oldtim, afram%, godit
fram% = fram% + 1
If Int(Timer) - oldtimer& Then
ofram% = fram%: fram% = 0: oldtimer& = Int(Timer)
End If
afram% = afram% + 1
If oldtim <> Timer Then
delta.t = delta.t * .8 + (Timer - oldtim) * .2 / afram%
oldtim = Timer: afram% = 0
If delta.t > .1 Or delta.t < 0 Then delta.t = .1
fdt = 14 * delta.t
End If
If kbmatrix%(36) And Timer > godit Then
If gm% Then gm% = 0 Else gm% = 1: 'cheat mode
godit = (Timer + 1) Mod 86400
End If
End Sub
Sub vline (x%, yt%, yb%, c%)
Static y%, xx%
Shared sb1%(), hicol%(), odd%(), bicol%(), bitex%: xx% = x% \ 2
If yt% < 8 Then yt% = 8
If yb% > 191 Then yb% = 191
If bitex% Then
For y% = yt% To yb%: sb1%(xx%, y%) = bicol%(c%): Next
ElseIf x% And 1 Then
For y% = yt% To yb%
sb1%(xx%, y%) = (sb1%(xx%, y%) And &HFF) + hicol%(c%): Next
Else
For y% = yt% To yb%: sb1%(xx%, y%) = (sb1%(xx%, y%) And &HFF00) + c%: Next
End If
End Sub
Sub yourmove
Shared kbmatrix%(), ct(), st(), efa%, shift, delta.t, fdt
Shared px, py, sa, va, vx, vy, testin%(), bx, by
If kbmatrix%(56) Then
If kbmatrix%(77) Then
vx = vx + ct((efa% + 450) Mod 1800) * shift * delta.t
vy = vy + st((efa% + 450) Mod 1800) * shift * delta.t
End If
If kbmatrix%(75) Then
vx = vx + ct((efa% + 1350) Mod 1800) * shift * delta.t
vy = vy + st((efa% + 1350) Mod 1800) * shift * delta.t
End If
Else
If kbmatrix%(77) Then va = va + shift * 90 * delta.t
If kbmatrix%(75) Then va = va - shift * 90 * delta.t
End If
If kbmatrix%(72) Then
vx = vx + ct(efa%) * shift * delta.t
vy = vy + st(efa%) * shift * delta.t
End If
If kbmatrix%(80) Then
vx = vx - ct(efa%) * shift * delta.t
vy = vy - st(efa%) * shift * delta.t
End If
svx% = Sgn(vx): svy% = Sgn(vy)
crashtest px + .15 * svx%, py + .15 * svy%, vx, vy
crashtest px - .15 * svx%, py + .15 * svy%, vx, vy
crashtest px + .15 * svx%, py - .15 * svy%, vx, vy
px = px + vx * delta.t: py = py + vy * delta.t
sa = (sa + va * delta.t) Mod 1800
damp = 2 ^ -fdt
vx = vx * damp: vy = vy * damp: va = va * damp
testin%(4, Int(bx) + 2, Int(by) + 19) = 0
End Sub
Sub yourshot
Shared kbmatrix%(), nshots%, weap$, sht(), ammo%(), shosht%(), bx, by, mg%
Shared fdt, delta.t, snd%, fb%, ct(), st(), vshx(), vshy(), maxshots%
Shared sizex%, sizey%, shtx(), shty(), map%(), inx%, iny%, testin%()
Shared shtang%(), shtdis(), dis(), dela%(), shtht%(), fmap%(), efa%, sa, plasma%()
Shared nbguys%, nbguysm1%, bgh%(), bgx(), bgy(), vbx(), vby(), fire, kills%, robo%()
Static kk%
If fire > 0 Then fire = fire - fdt * nshots%
If kbmatrix%(2) Then mg% = 0: kk% = 0: nshots% = 1: weap$ = " plasma gun"
If kbmatrix%(3) Then mg% = 1: nshots% = 10: weap$ = "machine gun"
If kbmatrix%(4) Then mg% = 2: nshots% = 10: weap$ = "plas-cannon"
If kbmatrix%(29) And fire <= 0 And sht(kk%) <= 0 And ammo%(mg% And 1) > 0 Then
sht(kk%) = 20: shosht%(kk%) = 1: ammo%(mg% And 1) = ammo%(mg% And 1) - 1: 'create shot
shtx(kk%) = bx: shty(kk%) = by: fire = 18: If snd% Then Sound 200, 1
vshx(kk%) = ct(efa%) * 10: vshy(kk%) = st(efa%) * 10
plasma%(kk%) = 1 - (mg% And 1)
kk% = kk% + 1: If kk% = nshots% Then kk% = 0
End If
For x% = 0 To maxshots%
If shtx(x%) < 1 Or shtx(x%) > sizex% - 1 Or shty(x%) < 0 Or shty(x%) > sizey% - 1 Then shosht%(x%) = 0
If sht(x%) > 0 Then sht(x%) = sht(x%) - fdt
If sht(x%) > 0 And shosht%(x%) Then
crashtest shtx(x%), shty(x%), vshx(x%), vshy(x%)
k% = map%(inx%, iny%)
If k% Then shosht%(x%) = 0
shtx(x%) = shtx(x%) + vshx(x%) * delta.t: shty(x%) = shty(x%) + vshy(x%) * delta.t
If k% = 15 And sht(x%) > 0 Then
map%(inx%, iny%) = 0
testin%(4, inx% + 2, iny% + 19) = 0
End If
shtang%(x%) = atan2(shty(x%) - by, shtx(x%) - bx) * 5
shtdis(x%) = Sqr((shty(x%) - by) ^ 2 + (shtx(x%) - bx) ^ 2 + .01)
dis(x% + nbguys% * 2) = shtdis(x%)
dela%(x%) = (shtang%(x%) - sa + 1800) Mod 1800
shtht%(x%) = 30 / shtdis(x%)
'damage test
For y% = 0 To nbguysm1%
bsdis = (shty(x%) - bgy(y%)) * (shty(x%) - bgy(y%)) + (shtx(x%) - bgx(y%)) * (shtx(x%) - bgx(y%))
If bsdis < .36 And bgh%(y%) > 0 Then
If bsdis < .16 Then bgh%(y%) = bgh%(y%) - sht(x%) / 2 - 5: shosht%(x%) = 0
'vbx(y%) = vbx(y%) + vshx(x%) * .1: vby(y%) = vby(y%) + vshy(x%) * .1
If plasma%(x%) Then
bgh%(y%) = bgh%(y%) - sht(x%) * 1.5 - 50: shosht%(x%) = 0
'vbx(y%) = vbx(y%) + vshx(x%) * .5: vby(y%) = vby(y%) + vshy(x%) * .5
End If
If bgh%(y%) < 1 Then
fmap%(Int(bgx(y%)), Int(bgy(y%))) = 4 + 4 * robo%(y%): kills% = kills% + 1
If snd% Then Sound 180, 5
End If
End If: Next
End If: Next
End Sub
Sub keys
Shared kbmatrix%()
i% = Inp(96): i$ = InKey$: kbmatrix%(i% And 127) = -(i% < 128)
End Sub
|
|
|
|
|
