| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 714
» Latest member: HenryG
» Forum threads: 3,569
» Forum posts: 31,908
Full Statistics
|
| Latest Threads |
4x4 Square Elimination Pu...
Forum: bplus
Last Post: bplus
2 hours ago
» Replies: 12
» Views: 405
|
Container Data Structure
Forum: Utilities
Last Post: bplus
2 hours ago
» Replies: 3
» Views: 110
|
Accretion Disk
Forum: Programs
Last Post: bplus
3 hours ago
» Replies: 11
» Views: 277
|
QB64PE v 4.4.0
Forum: Announcements
Last Post: Unseen Machine
11 hours ago
» Replies: 7
» Views: 655
|
QBJS v0.10.0 - Release
Forum: QBJS, BAM, and Other BASICs
Last Post: Unseen Machine
11 hours ago
» Replies: 13
» Views: 1,289
|
Arrays inside Types?
Forum: General Discussion
Last Post: hsiangch_ong
Today, 03:24 AM
» Replies: 47
» Views: 1,401
|
Has anybody experience wi...
Forum: Help Me!
Last Post: Rudy M
Yesterday, 08:47 AM
» Replies: 31
» Views: 1,936
|
Sorting numbers - FiliSor...
Forum: Utilities
Last Post: PhilOfPerth
03-11-2026, 12:48 AM
» Replies: 11
» Views: 315
|
Quick Sort for variable l...
Forum: Utilities
Last Post: SMcNeill
03-10-2026, 03:14 PM
» Replies: 3
» Views: 88
|
Ready for Easter!
Forum: Holiday Code
Last Post: bplus
03-10-2026, 12:15 PM
» Replies: 0
» Views: 58
|
|
|
| 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: 254)
|
|
|
| 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
|
|
|
|
| Navigating QB64Phoenix |
|
Posted by: Dimster - 04-17-2022, 03:21 PM - Forum: General Discussion
- Replies (8)
|
|
Hi Steve . I know you must still have a lot on your plate getting this site organized, so there is no hurry in responding to this post.
I have been checking things out and have a few questions on how things work and how you may envision how members should navigate around the site.
The Home page is the Portal page correct. There is no other page that you would recommend a LOGIN member to use, v's an UNlogin or visitor?
On the Portal page, there are 4 main screen to jump to - General Discussion, Site Suggestions, Programs, Work in Progress. Is that correct, or will/does the Portal page have many more places to jump directly to?
I absolutely love the personal welcome column. Its there whether I login in or not. My question here is in the SEARCH. What can I search here? Is it the entire site including the wiki or the entire site excluding the wiki? Any chance the search could include the web? Like search "How many feet in a mile?".
Not sure I understand what "Thread Subscription" is all about. Is it a connection to a particular topic in general discussions, just my topic in general discussions, just follow all the postings of a particular member or all of the above??
Is there a way of holding a Post which is in the process of being composed, jumping out to say General Discussions, then jump back to complete the Post in progress without Saving a Draft??
Thanks Steve
|
|
|
|
| ODBC SQL (Windows) |
|
Posted by: SpriggsySpriggs - 04-17-2022, 02:08 AM - Forum: Programs
- No Replies
|
 |
Here is some code for using the ODBC SQL API in Windows. Testing has been done primarily in 64 bit but I am confident it will work in 32 as well. This code, in my opinion, does a good job of using the features in the ODBC API in Windows. I have tried to model it around the original Wiki example for MySQL, with some cleanup  Note, you will need to create a new 64 bit data source if you are compiling in 64 bit. 32 for 32. ODBC is more secure since you are not storing your server's information in the code.
Follow this link to see how to add a new data source:
Administer ODBC data sources
ODBC supports all SQL variants. You just need to use the proper syntax for your flavor.
Code: (Select All) Option Explicit
$NoPrefix
$Console:Only
$VersionInfo:Comments=Testing ODBC connections in Windows using QB64
'$ExeIcon:'databases.ico'
'Icon
Type SQL_FIELD
As Integer type
As Unsigned Integer size
As Byte isNullable
As Integer decimalDigits
As String columnName, value
End Type
Const SQL_SUCCESS = 0
Dim Shared As Offset hEnv, hDbc, hStmt
ReDim Shared As SQL_FIELD DB_Result(1 To 1, 1 To 1)
Dim Shared As String ConnectionString
Dim As String datasource: datasource = "SpriggsyWinServer" 'use your data source name here
If DB_Open(datasource) Then
If datasource <> "" Then
Dim As String conTitle: conTitle = "ODBC Test - " + datasource: ConsoleTitle conTitle
Else
conTitle = "ODBC Test": ConsoleTitle conTitle
End If
If DB_QUERY("SELECT * FROM root.table1") = SQL_SUCCESS Then 'insert your own query here
DB_DetailResult
End If
DB_Close
Else System
End If
Declare Dynamic Library "odbc32"
Sub SQLAllocHandle (ByVal HandleType As Integer, Byval InputHandle As Offset, Byval OutputHandlePtr As Offset)
Function SQLGetDiagRec%& (ByVal HandleType As Integer, Byval Handle As Offset, Byval RecNumber As Integer, Byval SQLState As Offset, Byval NativeErrorPtr As Offset, Byval MessageText As Offset, Byval BufferLength As Integer, Byval TextLengthPtr As Offset)
Sub SQLSetEnvAttr (ByVal EnvironmentHandle As Offset, Byval Attribute As Long, Byval ValuePtr As Offset, Byval StringLength As Long)
Function SQLDriverConnect%& (ByVal ConnectionHandle As Offset, Byval WindowHandle As Offset, InConnectionString As String, Byval StringLength1 As Integer, Byval OutConnectionString As Offset, Byval BufferLength As Integer, Byval StringLength2Ptr As Offset, Byval DriverCompletion As Unsigned Integer)
Sub SQLPrepare (ByVal StatementHandle As Offset, StatementText As String, Byval TextLength As Long)
Sub SQLExecute (ByVal StatementHandle As Offset)
Function SQLExecute%& (ByVal StatementHandle As Offset)
Sub SQLNumResultCols (ByVal StatementHandle As Offset, Byval ColumnCountPtr As Offset)
Sub SQLDescribeCol (ByVal StatementHandle As Offset, Byval ColumnNumber As Unsigned Integer, Byval ColumnName As Offset, Byval BufferLength As Integer, Byval NameLengthPtr As Offset, Byval DataTypePtr As Offset, Byval ColumnSizePtr As Offset, Byval DecimalDigitsPtr As Offset, Byval NullablePtr As Offset)
Function SQLFetch%& (ByVal StatementHandle As Offset)
Function SQLGetData%& (ByVal StatementHandle As Offset, Byval ColOrParamNum As Unsigned Integer, Byval TargetType As Integer, Byval TargetValuePtr As Offset, Byval BufferLength As Offset, Byval StrLenOrIndPtr As Offset)
Function SQLRowCount%& (ByVal StatementHandle As Offset, Byval RowCountPtr As Offset)
Sub SQLFreeHandle (ByVal HandleType As Integer, Byval Handle As Offset)
Sub SQLDisconnect (ByVal ConnectionHandle As Offset)
End Declare
Declare CustomType Library
Function GetDesktopWindow%& ()
End Declare
Function DB_Open%% (dsn As String)
Const SQL_HANDLE_ENV = 1
Const SQL_HANDLE_DBC = 2
Const SQL_HANDLE_STMT = 3
Const SQL_DRIVER_COMPLETE = 1
Const SQL_NULL_HANDLE = 0
Const SQL_NTS = -3
Const SQL_ATTR_ODBC_VERSION = 200
Const SQL_OV_ODBC3 = 3~&
Dim As Offset ret
SQLAllocHandle SQL_HANDLE_ENV, SQL_NULL_HANDLE, Offset(hEnv)
SQLSetEnvAttr hEnv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, 0
SQLAllocHandle SQL_HANDLE_DBC, hEnv, Offset(hDbc)
Dim As String outstr: outstr = Space$(1024)
Dim As Integer outstrlen
If dsn = "" Then
ret = SQLDriverConnect(hDbc, GetDesktopWindow, "", SQL_NTS, Offset(outstr), Len(outstr), Offset(outstrlen), SQL_DRIVER_COMPLETE)
Else
ret = SQLDriverConnect(hDbc, 0, "DSN=" + dsn + ";", SQL_NTS, Offset(outstr), Len(outstr), Offset(outstrlen), SQL_DRIVER_COMPLETE)
End If
ConnectionString = Mid$(outstr, 1, outstrlen)
SQLAllocHandle SQL_HANDLE_STMT, hDbc, Offset(hStmt)
If SQL_SUCCEEDED(ret) Then
DB_Open = -1
Else
DB_Error "DB_Open", hDbc, SQL_HANDLE_DBC
DB_Open = 0
End If
End Function
Sub DB_Open (dsn As String)
Const SQL_HANDLE_ENV = 1
Const SQL_HANDLE_DBC = 2
Const SQL_HANDLE_STMT = 3
Const SQL_DRIVER_COMPLETE = 1
Const SQL_NULL_HANDLE = 0
Const SQL_NTS = -3
Const SQL_ATTR_ODBC_VERSION = 200
Const SQL_OV_ODBC3 = 3~&
Dim As Offset ret
SQLAllocHandle SQL_HANDLE_ENV, SQL_NULL_HANDLE, Offset(hEnv)
SQLSetEnvAttr hEnv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, 0
SQLAllocHandle SQL_HANDLE_DBC, hEnv, Offset(hDbc)
Dim As String outstr: outstr = Space$(1024 + 1)
Dim As Integer outstrlen
If dsn = "" Then
ret = SQLDriverConnect(hDbc, GetDesktopWindow, "", SQL_NTS, Offset(outstr), Len(outstr), Offset(outstrlen), SQL_DRIVER_COMPLETE)
Else
ret = SQLDriverConnect(hDbc, 0, "DSN=" + dsn + ";", SQL_NTS, Offset(outstr), Len(outstr), Offset(outstrlen), SQL_DRIVER_COMPLETE)
End If
ConnectionString = Mid$(outstr, 1, outstrlen)
SQLAllocHandle SQL_HANDLE_STMT, hDbc, Offset(hStmt)
If Not (SQL_SUCCEEDED(ret)) Then
DB_Error "DB_Open", hDbc, SQL_HANDLE_DBC
End If
End Sub
Sub DB_QUERY (sql_command As String)
Const SQL_CHAR = 1
Const SQL_C_CHAR = SQL_CHAR
Const SQL_NO_NULLS = 0
Const SQL_NULLABLE = 1
Const SQL_NULLABLE_UNKNOWN = 2
Const SQL_NULL_DATA = -1
Const SQL_NTS = -3
Dim As Offset ret, execCode
SQLPrepare hStmt, sql_command, SQL_NTS
execCode = SQLExecute(hStmt)
If SQL_SUCCEEDED(execCode) Then
Dim As Integer columns
SQLNumResultCols hStmt, Offset(columns)
ret = SQLFetch(hStmt)
Dim As Long row
While SQL_SUCCEEDED(ret)
Dim As Unsigned Integer i
row = row + 1
For i = 1 To columns
Dim As Long indicator
Dim As String buf: buf = Space$(4096 + 1)
Dim As String columnName: columnName = Space$(128)
Dim As Integer colNameLength, dataType, decimalDigits, nullable
Dim As Unsigned Integer columnSize
ret = SQLGetData(hStmt, i, SQL_C_CHAR, Offset(buf), Len(buf), Offset(indicator))
If SQL_SUCCEEDED(ret) Then
ReDim Preserve As SQL_FIELD DB_Result(columns, row)
buf = Mid$(buf, 1, indicator)
If indicator = SQL_NULL_DATA Then buf = "NULL"
SQLDescribeCol hStmt, i, Offset(columnName), Len(columnName), Offset(colNameLength), Offset(dataType), Offset(columnSize), Offset(decimalDigits), Offset(nullable)
columnName = Mid$(columnName, 1, colNameLength)
DB_Result(i, row).type = dataType
DB_Result(i, row).size = columnSize
DB_Result(i, row).decimalDigits = decimalDigits
DB_Result(i, row).columnName = columnName
DB_Result(i, row).value = buf
Select Case nullable
Case SQL_NO_NULLS
DB_Result(i, row).isNullable = 0
Case SQL_NULLABLE
DB_Result(i, row).isNullable = -1
End Select
End If
Next
ret = SQLFetch(hStmt)
Wend
Else
DB_Error "DB_QUERY", hStmt, 3
End If
End Sub
Function DB_QUERY%& (sql_command As String)
Const SQL_CHAR = 1
Const SQL_C_CHAR = SQL_CHAR
Const SQL_NO_NULLS = 0
Const SQL_NULLABLE = 1
Const SQL_NULLABLE_UNKNOWN = 2
Const SQL_NULL_DATA = -1
Const SQL_NTS = -3
Const SQL_SUCCESS = 0
Dim As Offset ret, execCode
SQLPrepare hStmt, sql_command, SQL_NTS
execCode = SQLExecute(hStmt)
If SQL_SUCCEEDED(execCode) Then
Dim As Integer columns
SQLNumResultCols hStmt, Offset(columns)
ret = SQLFetch(hStmt)
Dim As Long row
While SQL_SUCCEEDED(ret)
Dim As Unsigned Integer i
row = row + 1
For i = 1 To columns
Dim As Long indicator
Dim As String buf: buf = Space$(4096 + 1)
Dim As String columnName: columnName = Space$(128)
Dim As Integer colNameLength, dataType, decimalDigits, nullable
Dim As Unsigned Integer columnSize
ret = SQLGetData(hStmt, i, SQL_C_CHAR, Offset(buf), Len(buf), Offset(indicator))
If SQL_SUCCEEDED(ret) Then
ReDim Preserve As SQL_FIELD DB_Result(columns, row)
buf = Mid$(buf, 1, indicator)
If indicator = SQL_NULL_DATA Then buf = "NULL"
SQLDescribeCol hStmt, i, Offset(columnName), Len(columnName), Offset(colNameLength), Offset(dataType), Offset(columnSize), Offset(decimalDigits), Offset(nullable)
columnName = Mid$(columnName, 1, colNameLength)
DB_Result(i, row).type = dataType
DB_Result(i, row).size = columnSize
DB_Result(i, row).decimalDigits = decimalDigits
DB_Result(i, row).columnName = columnName
DB_Result(i, row).value = buf
Select Case nullable
Case SQL_NO_NULLS
DB_Result(i, row).isNullable = 0
Case SQL_NULLABLE
DB_Result(i, row).isNullable = -1
End Select
End If
Next
ret = SQLFetch(hStmt)
Wend
Else
DB_Error "DB_QUERY", hStmt, 3
End If
DB_QUERY = execCode
End Function
Function DB_Esc$ (columnName As String)
DB_Esc = "`" + columnName + "`"
End Function
Function DB_Q$ (value As String)
DB_Q = "'" + value + "'"
End Function
Function DB_AffectedRows%&
Dim As Offset rowCount
Dim As Offset ret: ret = SQLRowCount(hStmt, Offset(rowCount))
If SQL_SUCCEEDED(ret) Then DB_AffectedRows = rowCount
End Function
Sub DB_DetailResult
Const SQL_DECIMAL = 3
Const SQL_NUMERIC = 2
Dim As Unsigned Integer row, column
Print "Connection: "; ConnectionString
For row = 1 To UBound(DB_Result, 2)
Print "Row"; row
For column = 1 To UBound(DB_Result, 1)
Print " "; column; GetDataType(DB_Result(column, row).type);
If DB_Result(column, row).type = SQL_DECIMAL Or DB_Result(column, row).type = SQL_NUMERIC Then
Print "("; Trim$(Str$(DB_Result(column, row).size)); ","; Trim$(Str$(DB_Result(column, row).decimalDigits)); ") ";
Else
Print "("; Trim$(Str$(DB_Result(column, row).size)); ") ";
End If
If DB_Result(column, row).isNullable = 0 Then
Print DB_Result(column, row).columnName; " "; DB_Result(column, row).value; " "; "Not nullable"
Else Print DB_Result(column, row).columnName; " "; DB_Result(column, row).value
End If
Next
Next
End Sub
Sub DB_Close
Const SQL_HANDLE_ENV = 1
Const SQL_HANDLE_DBC = 2
SQLDisconnect (hDbc)
SQLFreeHandle SQL_HANDLE_DBC, hDbc
SQLFreeHandle SQL_HANDLE_ENV, hEnv
End Sub
Function GetDataType$ (dataType As Integer)
Const SQL_CHAR = 1
Const SQL_C_CHAR = SQL_CHAR
Const SQL_VARCHAR = 12
Const SQL_LONGVARCHAR = -1
Const SQL_WCHAR = -8
Const SQL_WVARCHAR = -9
Const SQL_WLONGVARCHAR = -10
Const SQL_DECIMAL = 3
Const SQL_NUMERIC = 2
Const SQL_SMALLINT = 5
Const SQL_INTEGER = 4
Const SQL_REAL = 7
Const SQL_FLOAT = 6
Const SQL_DOUBLE = 8
Const SQL_BIT = -7
Const SQL_TINYINT = -6
Const SQL_BIGINT = -5
Const SQL_BINARY = -2
Const SQL_VARBINARY = -3
Const SQL_LONGVARBINARY = -4
Const SQL_TYPE_DATE = 91
Const SQL_TYPE_TIME = 92
Const SQL_TYPE_TIMESTAMP = 93
Const SQL_INTERVAL_MONTH = -81
Const SQL_INTERVAL_YEAR = -80
Const SQL_INTERVAL_YEAR_TO_MONTH = -82
Const SQL_INTERVAL_DAY = -83
Const SQL_INTERVAL_HOUR = -84
Const SQL_INTERVAL_MINUTE = -85
Const SQL_INTERVAL_SECOND = -86
Const SQL_INTERVAL_DAY_TO_HOUR = -87
Const SQL_INTERVAL_DAY_TO_MINUTE = -88
Const SQL_INTERVAL_DAY_TO_SECOND = -89
Const SQL_INTERVAL_HOUR_TO_MINUTE = -90
Const SQL_INTERVAL_HOUR_TO_SECOND = -91
Const SQL_INTERVAL_MINUTE_TO_SECOND = -92
Const SQL_GUID = -11
Select Case dataType
Case SQL_CHAR, SQL_C_CHAR
GetDataType = "CHAR"
Case SQL_VARCHAR
GetDataType = "VARCHAR"
Case SQL_LONGVARCHAR
GetDataType = "LONG VARCHAR"
Case SQL_WCHAR
GetDataType = "WCHAR"
Case SQL_WVARCHAR
GetDataType = "VARWCHAR"
Case SQL_WLONGVARCHAR
GetDataType = "LONGWVARCHAR"
Case SQL_DECIMAL
GetDataType = "DECIMAL"
Case SQL_NUMERIC
GetDataType = "NUMERIC"
Case SQL_SMALLINT
GetDataType = "SMALLINT"
Case SQL_INTEGER
GetDataType = "INTEGER"
Case SQL_REAL
GetDataType = "REAL"
Case SQL_FLOAT
GetDataType = "FLOAT"
Case SQL_DOUBLE
GetDataType = "DOUBLE PRECISION"
Case SQL_BIT
GetDataType = "BIT"
Case SQL_TINYINT
GetDataType = "TINYINT"
Case SQL_BIGINT
GetDataType = "BIGINT"
Case SQL_BINARY
GetDataType = "BINARY"
Case SQL_VARBINARY
GetDataType = "VARBINARY"
Case SQL_LONGVARBINARY
GetDataType = "LONG VARBINARY"
Case SQL_TYPE_DATE
GetDataType = "DATE"
Case SQL_TYPE_TIME
GetDataType = "TIME"
Case SQL_TYPE_TIMESTAMP
GetDataType = "TIMESTAMP"
Case SQL_INTERVAL_MONTH
GetDataType = "INTERVAL MONTH"
Case SQL_INTERVAL_YEAR
GetDataType = "INTERVAL YEAR"
Case SQL_INTERVAL_YEAR_TO_MONTH
GetDataType = "INTERVAL YEAR TO MONTH"
Case SQL_INTERVAL_DAY
GetDataType = "INTERVAL DAY"
Case SQL_INTERVAL_HOUR
GetDataType = "INTERVAL HOUR"
Case SQL_INTERVAL_MINUTE
GetDataType = "INTERVAL MINUTE"
Case SQL_INTERVAL_SECOND
GetDataType = "INTERVAL SECOND"
Case SQL_INTERVAL_DAY_TO_HOUR
GetDataType = "INTERVAL DAY TO HOUR"
Case SQL_INTERVAL_DAY_TO_MINUTE
GetDataType = "INTERVAL DAY TO MINUTE"
Case SQL_INTERVAL_DAY_TO_SECOND
GetDataType = "INTERVAL DAY TO SECOND"
Case SQL_INTERVAL_HOUR_TO_MINUTE
GetDataType = "INTERVAL HOUR TO MINUTE"
Case SQL_INTERVAL_HOUR_TO_SECOND
GetDataType = "INTERVAL HOUR TO SECOND"
Case SQL_INTERVAL_MINUTE_TO_SECOND
GetDataType = "INTERVAL MINUTE TO SECOND"
Case SQL_GUID
GetDataType = "GUID"
End Select
End Function
Sub DB_Error (__fn As String, handle As Offset, __type As Integer)
Const SQL_SUCCESS = 0
Const MB_OK = 0 'OK button only
Const MB_ICONEXCLAMATION = 48
Dim As Long i, NativeError
Dim As String SQLState: SQLState = Space$(5 + 1)
Dim As String MessageText: MessageText = Space$(256 + 1)
Dim As Integer TextLength
Dim As Offset ret
Do
i = i + 1
ret = SQLGetDiagRec(__type, handle, i, Offset(SQLState), Offset(NativeError), Offset(MessageText), Len(MessageText), Offset(TextLength))
If SQL_SUCCEEDED(ret) Then
MessageBox 0, "Error reported in " + __fn + ":" + Chr$(10) + Mid$(SQLState, 1, InStr(SQLState, Chr$(0)) - 1) + ":" + Trim$(Str$(i)) + ":" + Trim$(Str$(NativeError)) + ":" + Mid$(MessageText, 1, TextLength) + Chr$(0), "ODBC Error" + Chr$(0), MB_OK Or MB_ICONEXCLAMATION
End If
Loop While ret = SQL_SUCCESS
End Sub
Function SQL_SUCCEEDED& (rc As Offset)
SQL_SUCCEEDED = (((rc) And (Not 1)) = 0)
End Function
$If MESSAGEBOX = UNDEFINED Then
Declare Library
Function MessageBox& (ByVal hWnd As _Offset, message As String, title As String, Byval uType As _Unsigned Long)
Sub MessageBox (ByVal hWnd As _Offset, message As String, title As String, Byval uType As _Unsigned Long)
End Declare
$Let MESSAGEBOX = TRUE
$End If
Some screenshots:
Happy coding, and let me know if you have any questions on how to use it or get started
|
|
|
|
|
