04-24-2022, 03:13 AM
(04-20-2022, 03:25 AM)Pete Wrote: I don't do games, either, but I got 1 kill! I guess it's just in my lovable nature.
Hey really nice 3-D effects! What else you got???
Pete
Thanks. For the game, it helps to strafe a lot.
Here are a few somewhat related programs:
Just for fun, RAY-SH.BAS, designed to be the world's most compact code for a raycaster demo:
Code: (Select All)
a$ = "1111111110010001100409011000010120110701101101011000000112345671"
For X = 0 To 63: L(X And 7, X \ 8) = Val(Mid$(a$, X + 1, 1)): Next: X = 1.5
Y = X: F = Atn(1): u = F / 9: Screen 7: Do: Wait 986, 8: For S = -160 To 159
t = Atn(S / 304): R = F + t: I = Cos(R) / 80: J = Sin(R) / 80: o = X: p = Y
n = 0: Do: o = o + I: p = p + J: n = n + 1: c = L(o, p): Loop Until c
H = 9000 / n / Cos(t): v = S + 160: Line (v, 0)-(v, 99 - H), 0
Line -(v, 99 + H), c: Line -(v, 319), 8: Next: I = Cos(F) / 9: J = Sin(F) / 9
a = Inp(96): m = (a = 80) - (a = 72): m = m And (L(X + I * m, Y + J * m) = 0)
X = X + I * m: Y = Y + J * m: F = F + u * ((a = 75) - (a = 77)): Loop Until 1 = a3D-X3-64.BAS, a 2010 robots graphic demo designed to work in QB 4.5, QB 64, and FreeBasic. It's not how I would do things now, since it's using tricks that are not needed except to work within QB 4.5's limits.
Code: (Select All)
'$lang:"qb" '/' 3D-X3.BAS 'kinem
DECLARE SUB DEFSHORT (s%) : DECLARE SUB setmouse (x%, y%, M%)
Dim Shared MULTIKEY%(128): '/ 'start QB 4.5 with /l /ah
'arrows to turn left, rt; arrow+alt to strafe; a,z to move up, down
DEFINT A-Z: DECLARE SUB painttile (t) : DECLARE SUB objhdr2 (file$)
DECLARE SUB yourmove () : DECLARE SUB debuf0 () : DECLARE SUB timeit ()
DECLARE SUB getdet (t) : DECLARE FUNCTION gettn (t) : DECLARE SUB showtiles ()
DECLARE FUNCTION tileside (pt, tile) : DECLARE SUB theirmove ()
DECLARE FUNCTION crossx! (pa1, pa2, pb1, pb2) : DECLARE SUB urangle ()
DECLARE FUNCTION frontq (t1, t2) : DECLARE SUB maketables ()
DECLARE SUB TLINEFRx (p1, p2) : DECLARE SUB TLINESIDEx (p1, p2, p3)
DECLARE SUB makeworld () : DECLARE SUB keys () : DECLARE SUB objload2 (file$)
DECLARE SUB onkb () : DECLARE SUB readassembly () : DECLARE SUB offkb () '/'
Dim Shared kbcontrol(128), keyboardonflag, qbkey(128) '/
Dim Shared qb, fb: Screen 13: DEFSHORT s: setmouse 0, 0, 0: fb = (qb = 0) '/'
If qb = 45 Then Call readassembly: onkb
If qb Then ReDim Shared sbq(1, 29440) '/
If fb Then ReDim Shared sbf(1 + 29440), spf(8 To 191, 319)
If qb Then Get (0, 8)-(319, 191), sbq() Else Get (0, 8)-(319, 191), sbf()
Const cx = 159.5, cy = 99.5, scx = 258!, scy = 215!, scr = 1.2, ok = -1
Const sleft = 0, sright = 319, scrtop = 8, scrbot = 191
Dim Shared hicol(255), pi!, inlft(scrtop To scrbot)
Dim Shared px(3) As Long, py(3) As Long, pz(3) As Long, inrt(scrtop To scrbot)
Dim Shared xx(3) As Long, yy(3) As Long, trymin As Long, trymax As Long
Dim Shared trlft(scrtop To scrbot) As Long, trrt(scrtop To scrbot) As Long
Dim Shared nobj, nactpt, npts, ntri, nactri, nquad, slx, srx, sby, sty
Dim Shared obvt, obfc
ReDim Shared rtxx(0) As Long, rtyy(0) As Long, stog(3, 1) As String
ReDim Shared ptx(0), pty(0), ptz(0), ticol(0), tog(3), otog(3)
ReDim Shared rtx(0) As Single, rty(0) As Single, rtz(0) As Single
ReDim Shared tipt(3, 0), triobj(0), kno(0), froc(0), hiticol(0)
ReDim Shared obj(0), opend(0), op1(0), obz(0), obx(0), oby(0), obphi(0)
ReDim Shared tnx(0) As Single, tny(0) As Single, tnz(0) As Single
ReDim Shared wc(0) As Single, wax(0) As Single, wby(0) As Single
Dim Shared crossy As Single, crossz As Single
Dim Shared nsx As Single, theta!, psi!, phi!
Dim Shared pvx, pvy, pvz, xnx!, xny!, xnz!, ynx!, yny!, ynz!
Dim Shared znx!, zny!, znz!, obscale!, obzy, nov, nof
Call maketables: makeworld: urangle: showtiles: debuf0: Locate 1, 30
If fb Then Print "FreeBasic" Else If qb = 64 Then Print "QB 64" Else Print "QB 4.5"
Print "arrows to turn left, rt"
Print "arrow+alt to strafe": Print "a,z to move up, down"
Print "press any key to start": tog(0) = Not fb
t = 0: Do: keys: For i = 1 To 127: t = t + MULTIKEY(i): Next: Loop Until t
Do: urangle: showtiles: debuf0: keys: yourmove: theirmove: timeit
Loop Until MULTIKEY(1): If qb = 45 Then Call offkb
'/'
kbisrdata: 'Keyboard interrupt data; routine from KEYB2.BAS by Angelo
Data &HE9,&H1D,0,&HE9,&H3C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,&H1E,&H31,&HC0,&H8E,&HD8,&HBE,&H24,0,&H0E,7
Data &HBF,&H14,0,&HFC,&HA5,&HA5,&H8C,&HC3,&H8E,&HC0,&HBF,&H24,0,&HB8
Data &H56,0,&HFA,&HAB,&H89,&HD8,&HAB,&HFB,&H1F,&HCB,&H1E,&H31,&HC0,&H8E
Data &HC0,&HBF,&H24,0,&HBE,&H14,0,&H0E,&H1F,&HFC,&HFA,&HA5,&HA5,&HFB
Data &H1F,&HCB,&HFB,&H9C,&H50,&H53,&H51,&H52,&H1E,&H56,&H06,&H57,&HE4,&H60
Data &HB4,1,&HA8,&H80,&H74,4,&HB4,0,&H24,&H7F,&HD0,&HE0,&H88,&HC3
Data &HB7,0,&HB0,0,&H2E,3,&H1E,&H12,0,&H2E,&H8E,&H1E,&H10,0
Data &H86,&HE0,&H89,&H07,&HE4,&H61,&H0C,&H82,&HE6,&H61,&H24,&H7F,&HE6,&H61
Data &HB0,&H20,&HE6,&H20,&H5F,7,&H5E,&H1F,&H5A,&H59,&H5B,&H58,&H9D,&HCF,-1
'/
Function crossx! (pa1, pa2, pb1, pb2)
Static ax As Single, ay As Single, az As Single
Static bx As Single, by As Single, bz As Single
ax = rtx(pa1) - rtx(pa2): ay = rty(pa1) - rty(pa2): az = rtz(pa1) - rtz(pa2)
bx = rtx(pb1) - rtx(pb2): by = rty(pb1) - rty(pb2): bz = rtz(pb1) - rtz(pb2)
crossx = ay * bz - az * by
crossy = -ax * bz + az * bx
crossz = ax * by - ay * bx
End Function
Sub debuf0
If qb Then
x = 0: For xpq = 1 To 14720: x = x Xor 1
sbq(0, xpq) = ticol(sbq(0, x)) + hiticol(sbq(1, x)): x = x + 1
sbq(1, xpq) = ticol(sbq(0, x)) + hiticol(sbq(1, x)): Next
Put (0, scrtop), sbq(), PSet: x = sbq(0, 0): y = sbq(1, 0): 'y = 184
ReDim sbq(1, 29440): sbq(0, 0) = x: sbq(1, 0) = y
Else
For y = 8 To 191: xpq = 2 + (y - 8) * 160: For x = 0 To 159: x2 = x * 2
sbf(xpq + x) = ticol(spf(y, x2)) + hiticol(spf(y, x2 + 1)): Next: Next
Put (0, scrtop), sbf(), PSet: ReDim spf(8 To 191, 319)
End If
End Sub
'/'
Sub DEFSHORT (s%)
End Sub '/
Function frontq (t1, t2)
Dim qa(3), qb(3), sidp, csb, csf
ftri = 0: '1 ==> t1 in front of t2, -1 ==> t1 behind t2, 0 ==> use x-buffer
np1 = 4 + (tipt(3, t1) = 0): np2 = 4 + (tipt(3, t2) = 0)
'check if t2 is fully in front or back of plane of t1
csb = 0: csf = 0: For p = 0 To np2 - 1: sidp = tileside(tipt(p, t2), t1)
csb = csb - (sidp >= 0): csf = csf - (sidp <= 0): Next
If csb = np2 Then ftri = -1: GoTo endfq
If csf = np2 Then ftri = 1: GoTo endfq
'check if t1 is fully in front or back of plane of t2
csb = 0: csf = 0: For p = 0 To np1 - 1: sidp = tileside(tipt(p, t1), t2)
csb = csb - (sidp >= 0): csf = csf - (sidp <= 0): Next
If csf = np1 Then ftri = -1: GoTo endfq
If csb = np1 Then ftri = 1: 'GOTO endfq
'else try xb
endfq: frontq = ftri
kno(t2) = t1: froc(t2) = ftri
End Function
Sub getdet (t)
p1 = tipt(0, t): p2 = tipt(1, t): p3 = tipt(2, t)
M# = rtz(p1) * (rtx(p2) * rty(p3) - rtx(p3) * rty(p2)) + rtz(p2) * (rtx(p3) * rty(p1) - rtx(p1) * rty(p3)) + rtz(p3) * (rtx(p1) * rty(p2) - rtx(p2) * rty(p1))
If M# > 0 Then
wax(t) = (rty(p1) * (rtz(p2) - rtz(p3)) + rty(p2) * (rtz(p3) - rtz(p1)) + rty(p3) * (rtz(p1) - rtz(p2))) / M#
wby(t) = -scr * (rtx(p1) * (rtz(p3) - rtz(p2)) + rtx(p2) * (rtz(p1) - rtz(p3)) + rtx(p3) * (rtz(p2) - rtz(p1))) / M#
wc(t) = scx * (rtx(p1) * (rty(p2) - rty(p3)) + rtx(p2) * (rty(p3) - rty(p1)) + rtx(p3) * (rty(p1) - rty(p2))) / M# - cx * wax(t) - cy * wby(t)
'wc(t) = scx * C! / M# - cx * wax(t) - cy * wby(t)
'scx / z = wc + wax * Xs + wby * Ys
End If
End Sub
Function gettn (t)
tp0 = tipt(0, t): tnx(t) = -crossx(tipt(1, t), tp0, tipt(2, t), tp0)
tny(t) = -crossy: tnz(t) = -crossz
pb = tipt(0, t)
gettn = ((rtx(pb) * tnx(t) + rty(pb) * tny(t) + rtz(pb) * tnz(t)) < 0!)
End Function
Sub keys
'/'
If qb = 64 Then
i = Inp(96): If i < 128 Then MULTIKEY(i) = -1
If i > 127 Then MULTIKEY(i - 128) = 0
ElseIf qb = 45 Then
For k = 0 To 127: MULTIKEY(k) = (qbkey(k) Or (MULTIKEY(k) And qbkey(42)))
Next
End If '/
If MULTIKEY(28) And otog(0) = 0 Then tog(0) = Not tog(0)
otog(0) = MULTIKEY(28)
If MULTIKEY(14) And otog(1) = 0 Then tog(1) = Not tog(1)
otog(1) = MULTIKEY(14)
'IF MULTIKEY(57) AND otog(2) = 0 THEN tog(2) = NOT tog(2)
'otog(2) = MULTIKEY(57)
Locate 25, 1: Print stog(0, -tog(0)); tog(1); ' stog(1, -tog(1)); stog(2, -tog(2));
End Sub
Sub maketables
pi! = Atn(1) * 4
For c = 0 To 255: hicol(c) = &H100 * (c + &H100 * (c > &H7F)): Next
For y = scrtop To scrbot: trlft(y) = sright + 1: trrt(y) = -1
inlft(y) = -1: inrt(y) = -1: Next
trymin = scrbot + 8: trymax = -1
stog(0, 0) = "ENTER toggle: WAITing for screen "
stog(0, 1) = "ENTER toggle: not WAITing "
End Sub
Sub makeworld
obscale! = 1: obzy = 0
file$ = "3D-X3.qo": Call objhdr2(file$)
nobj = 10: npts = obvt * nobj: ntri = obfc * nobj
stfl = npts + 1: nobj = nobj + 1: npts = npts + 4: ntri = ntri + 1
ReDim rtxx(npts) As Long, rtyy(npts) As Long, hiticol(ntri)
ReDim ptx(-1 To npts), pty(-1 To npts), ptz(-1 To npts), ticol(ntri)
ReDim rtx(-1 To npts) As Single, rty(-1 To npts) As Single, rtz(-1 To npts) As Single
ReDim tipt(3, ntri), triobj(1 To ntri), kno(ntri), froc(ntri)
ReDim obj(npts), opend(nobj), op1(nobj), obz(nobj), obx(nobj), oby(nobj), obphi(nobj)
ReDim tnx(1 To ntri) As Single, tny(1 To ntri) As Single, tnz(1 To ntri) As Single
ReDim wc(ntri) As Single, wax(ntri) As Single, wby(ntri) As Single
pvx = -50: pvy = 100: pvz = -175: phi! = 0 * pi! / 180
For n = 0 To nobj - 1 - 1: obn = n + 1: Call objload2(file$)
op1(obn) = 1 + obvt * n: opend(obn) = op1(obn) + obvt - 1
obx(obn) = 32 + 100 * n: obz(obn) = 32: oby(obn) = 0
For t = op1(obn) To opend(obn): obj(t) = obn: Next: Next
op1(nobj) = stfl: opend(nobj) = stfl + 3: nactri = ntri
For t = 0 To 3: tipt(t, ntri) = stfl + t: obj(stfl + 1) = nobj: Next
ptx(stfl) = -4000: ptz(stfl) = -4000
ptx(stfl + 1) = 4000: ptz(stfl + 1) = -4000
ptx(stfl + 2) = 4000: ptz(stfl + 2) = 4000
ptx(stfl + 3) = -4000: ptz(stfl + 3) = 4000
ticol(ntri) = 9: oby(nobj) = 90
For t = 1 To ntri: hiticol(t) = hicol(ticol(t)): Next
End Sub
Sub objhdr2 (file$)
Dim geo As String * 1, geo2 As String * 1, i As Long
obvt = 0: obfc = 0
Open file$ For Random As #1 Len = 1
For i = 1 To LOF(1)
Get #1, i, geo: g = Asc(geo)
If geo = "#" Then
Do: i = i + 1: Get #1, i, geo: g = Asc(geo)
Loop Until EOF(1) Or g = 13 Or g = 10 Or geo = "#"
End If
If geo = "v" Then
Get #1, i + 1, geo2
If geo2 = " " Then obvt = obvt + 1
End If
If geo = "f" Then
Get #1, i + 1, geo2
If geo2 = " " Then obfc = obfc + 1
End If
Next: Close #1
End Sub
Sub objload2 (file$)
Dim pth(3) As Single, geo As String * 1, geo2 As String * 1, i As Long
Dim orig(2) As Single
nov0 = nov: orig(0) = 0: orig(1) = 0: orig(2) = 0: col = 8
Open file$ For Random As #1 Len = 1
For i = 1 To LOF(1)
Get #1, i, geo: g = Asc(geo)
If geo = "#" Then
Do: i = i + 1: Get #1, i, geo: g = Asc(geo): 'PRINT geo;
Loop Until EOF(1) Or g = 13 Or g = 10 Or geo = "#"
End If
If geo = "o" Then
Get #1, i + 1, geo2
If geo2 = " " Then
f$ = "": p = 0
Do: nn = 0: Do: i = i + 1: Get #1, i, geo
If (geo >= "0" And geo <= "9") Or geo = "." Or geo = "-" Or geo = "e" Then
f$ = f$ + geo
Else
nn = -1
End If
Loop Until nn = -1 Or EOF(1)
If Len(f$) > 0 Then pth(p) = Val(f$): p = p + 1: f$ = ""
Loop Until p = 3 Or EOF(1): 'fix xyz
orig(0) = pth(0): orig(1) = pth(1): orig(2) = pth(2)
End If
End If
If geo = "v" Then
Get #1, i + 1, geo2
If geo2 = " " Then
nov = nov + 1: f$ = "": p = 0
Do: nn = 0: Do: i = i + 1: Get #1, i, geo
If (geo >= "0" And geo <= "9") Or geo = "." Or geo = "-" Or geo = "e" Then
f$ = f$ + geo
Else
nn = -1
End If
Loop Until nn = -1 Or EOF(1)
If Len(f$) > 0 Then pth(p) = Val(f$) - orig(p): p = p + 1: f$ = ""
Loop Until p = 3 Or EOF(1): 'fix xyz
If obzy Then
ptx(nov) = pth(0) * obscale!:
pty(nov) = pth(1) * obscale!: ptz(nov) = pth(2) * obscale!
Else
ptx(nov) = pth(0) * obscale!:
ptz(nov) = pth(1) * obscale!: pty(nov) = pth(2) * obscale!
End If
Else
vn = vn + 1
End If
End If
If geo = "f" Then
Get #1, i + 1, geo2
If geo2 = " " Then
nof = nof + 1: f$ = "": p = 0
Do: nn = 0: Do: i = i + 1: Get #1, i, geo
If (geo >= "0" And geo <= "9") Then f$ = f$ + geo Else nn = -1
Loop Until nn = -1 Or EOF(1)
If Len(f$) > 0 Then tipt(p, nof) = Val(f$) + nov0: p = p + 1: f$ = ""
Loop Until geo = "c" Or geo = Chr$(10) Or p = 4 Or EOF(1) ' fix for more on same line
If p = 3 Or p = 4 Then nactri = nactri + 1
If p = 4 Then i = i + 1: Get #1, i, geo
If geo = "c" Then
Do: i = i + 1: Get #1, i, geo2: Loop Until geo2 <> " ": f$ = geo2
Do: i = i + 1: Get #1, i, geo2: f$ = f$ + geo2
Loop Until geo2 = Chr$(10) Or EOF(1)
col = Val(f$) Mod 256
End If
ticol(nof) = col
End If
End If
Next: Close #1
'PRINT vt, fc: PRINT nov, nof: SLEEP
End Sub
Sub offkb
'/'
If (keyboardonflag% = 0) Then Exit Sub
keyboardonflag% = 0
Def Seg = VarSeg(kbcontrol%(0))
Call Absolute(3)
Def Seg '/
End Sub
Sub onkb
'/'
If keyboardonflag% Then Exit Sub
keyboardonflag% = 1
Def Seg = VarSeg(kbcontrol%(0))
Call Absolute(0)
Def Seg '/
End Sub
Sub painttile (t)
kno(t) = 0: kno(0) = t: sgb% = 0: typ = 0: froc(0) = 1
If tipt(3, t) = 0 Then
For p = 0 To 2
px(p) = rtx(tipt(p, t)): py(p) = rty(tipt(p, t)): pz(p) = rtz(tipt(p, t))
If pz(p) > 0 Then
xx(p) = rtxx(tipt(p, t)): yy(p) = rtyy(tipt(p, t))
Else
typ = typ + 1
End If
Next
Select Case typ
Case 0: If xx(0) < 0 And xx(1) < 0 And xx(2) < 0 Then Exit Sub
If xx(0) > sright And xx(1) > sright And xx(2) > sright Then Exit Sub
If yy(0) < scrtop And yy(1) < scrtop And yy(2) < scrtop Then Exit Sub
If yy(0) > scrbot And yy(1) > scrbot And yy(2) > scrbot Then Exit Sub
TLINEFRx 0, 1: TLINEFRx 0, 2: TLINEFRx 1, 2
Case 1: pt1 = 0: pt2 = 1: pt3 = 2
If pz(pt1) <= 0 Then
If pz(pt2) <= 0 Then Swap pt1, pt3 Else Swap pt1, pt2
End If
If pz(pt2) <= 0 Then Swap pt2, pt3
TLINESIDEx pt1, pt2, pt3: TLINESIDEx pt1, pt3, pt2: TLINESIDEx pt2, pt3, pt1
Case 2: pt1 = 0: pt2 = 1: pt3 = 2
If pz(pt1) <= 0 Then
If pz(pt2) <= 0 Then Swap pt1, pt3 Else Swap pt1, pt2
End If
TLINESIDEx pt1, pt2, pt3: TLINESIDEx pt1, pt3, pt2
Case 3: Exit Sub
End Select
Else
For p = 0 To 3
px(p) = rtx(tipt(p, t)): py(p) = rty(tipt(p, t)): pz(p) = rtz(tipt(p, t))
If pz(p) > 0 Then
xx(p) = rtxx(tipt(p, t)): yy(p) = rtyy(tipt(p, t))
Else
typ = typ + 1
End If
Next
Select Case typ
Case 4: Exit Sub
Case 0: If xx(0) < 0 And xx(1) < 0 And xx(2) < 0 And xx(3) < 0 Then Exit Sub
If xx(0) > sright And xx(1) > sright And xx(2) > sright And xx(3) > sright Then Exit Sub
If yy(0) < scrtop And yy(1) < scrtop And yy(2) < scrtop And yy(3) < scrtop Then Exit Sub
If yy(0) > scrbot And yy(1) > scrbot And yy(2) > scrbot And yy(3) > scrbot Then Exit Sub
TLINEFRx 0, 1: TLINEFRx 1, 2: TLINEFRx 2, 3: TLINEFRx 3, 0
Case Else 'pt1 = 0: pt2 = 1: pt3 = 2: pt4 = 3
For pt = 0 To 3: pt1 = pt: pt2 = (pt + 1) Mod 4: pt3 = (pt + 2) Mod 4
If pz(pt1) > 0 Or pz(pt2) > 0 Then
If pz(pt1) <= 0 Then Swap pt1, pt2
TLINESIDEx pt1, pt2, pt3
End If: Next
End Select
End If
getdet (t)
If qb Then
xpq = 160 * (trymin - scrtop) - 159
For y = trymin To trymax: xpq = xpq + 160
If trlft(y) <= sright And trrt(y) >= 0 Then
If trlft(y) < 0 Then trlft(y) = 0
If trrt(y) > sright Then trrt(y) = sright
rtyx = trrt(y): For x = trlft(y) To rtyx
sgb% = sbq(x And 1, x \ 2 + xpq)
If kno(sgb%) = t Then ft = froc(sgb%) Else ft = frontq(t, sgb%)
Select Case ft:
Case 1:
For x = x To rtyx: x2 = x \ 2 + xpq
If sgb% <> sbq(x And 1, x2) Then x = x - 1: Exit For
sbq(x And 1, x2) = t
Next
Case -1:
If sbq(rtyx And 1, rtyx \ 2 + xpq) = sgb% Then x = rtyx + 1
For x = x To rtyx
If sgb% <> sbq(x And 1, x \ 2 + xpq) Then x = x - 1: Exit For
x5 = x + 5: If x5 <= rtyx Then If sgb% = sbq(x5 And 1, x5 \ 2 + xpq) Then x = x5
Next
Case 0:
c3d! = wax(t) - wax(sgb%): xside = Sgn(c3d!)
c2d! = wc(sgb%) - wc(t) + y * (wby(sgb%) - wby(t))
If xside Then
x00! = c2d! / c3d!
If x00! > 320 Then x0 = 320 Else If x00! < -1 Then x0 = -1 Else x0 = x00!
Else
x0 = 320: xside = (x * c3d! - c2d! >= 0)
End If
If (x0 = 320 And xside = 1) Or (x0 = -1 And xside = -1) Then
If sbq(rtyx And 1, rtyx \ 2 + xpq) = sgb% Then x = rtyx + 1
End If
'IF x < x0 AND xside = 1 THEN
'IF x0 > -1 AND x0 < 320 THEN
'IF sbq(x0 AND 1, x0 \ 2 + xpq) = sgb% THEN x = x0
'END IF
'END IF
For x = x To rtyx: x2 = x \ 2 + xpq
If sgb% <> sbq(x And 1, x2) Then x = x - 1: Exit For
If Sgn(x - x0) = xside Then sbq(x And 1, x2) = t
Next
End Select
Next x
End If
trlft(y) = sright + 1: trrt(y) = -1: inlft(y) = -1: inrt(y) = -1
Next y: trymin = scrbot + 8: trymax = -1
Else
'fb
For y = trymin To trymax
If trlft(y) <= sright And trrt(y) >= 0 Then
If trlft(y) < 0 Then trlft(y) = 0
If trrt(y) > sright Then trrt(y) = sright
c2! = wc(t) + y * wby(t)
rtyx = trrt(y): For x = trlft(y) To rtyx: sgb% = spf(y, x)
If kno(sgb%) = t Then ft = froc(sgb%) Else ft = frontq(t, sgb%)
Select Case ft:
Case 1:
For x = x To rtyx
If sgb% <> spf(y, x) Then x = x - 1: Exit For
spf(y, x) = t
Next
Case -1:
If spf(y, rtyx) = sgb% Then x = rtyx + 1
For x = x To rtyx: If sgb% <> spf(y, x) Then x = x - 1: Exit For
x5 = x + 5: If x5 <= rtyx Then If sgb% = spf(y, x5) Then x = x5
Next
Case 0:
c3d! = wax(t) - wax(sgb%): xside = Sgn(c3d!)
c2d! = wc(sgb%) - wc(t) + y * (wby(sgb%) - wby(t))
If xside Then
x00! = c2d! / c3d!
If x00! > 320 Then x0 = 320 Else If x00! < -1 Then x0 = -1 Else x0 = x00!
Else
x0 = 320: xside = (x * c3d! - c2d! >= 0)
End If
If (x0 = 320 And xside = 1) Or (x0 = -1 And xside = -1) Then
If spf(y, rtyx) = sgb% Then x = rtyx + 1
End If
For x = x To rtyx
If sgb% <> spf(y, x) Then x = x - 1: Exit For
If Sgn(x - x0) = xside Then spf(y, x) = t
Next
End Select
Next x
End If
trlft(y) = sright + 1: trrt(y) = -1: inlft(y) = -1: inrt(y) = -1
Next y: trymin = scrbot + 8: trymax = -1
End If
End Sub
Sub readassembly
'/'
Restore kbisrdata: Def Seg = VarSeg(kbcontrol%(0)): i& = 0: GoTo skip0
Do: Poke i&, q%: i& = i& + 1
skip0:
Read q%:
Loop While q% > -1: i& = 16
n& = VarSeg(qbkey%(0)): L& = n& And 255: h& = ((n& And &HFF00) \ 256)
Poke i&, L&: Poke i& + 1, h&: i& = i& + 2
n& = VarPtr(qbkey%(0)): L& = n& And 255: h& = ((n& And &HFF00) \ 256)
Poke i&, L&: Poke i& + 1, h&: i& = i& + 2
Def Seg '/
End Sub
'/'
Sub setmouse (x%, y%, M%)
Circle (2, 2), 2
If Point(1, 0) Then qb = 45 Else qb = 64
Locate 1, 1: Print " "
End Sub '/
Sub showtiles
For t = 1 To nactri: If gettn(t) Then painttile t
Next
End Sub
Sub theirmove
Static otm&
For o = 1 To nobj - 1: 'dzo = 2 * (RND - .5)
obz(o) = obz(o) + dzo: obphi(o) = obphi(o) + (-1) ^ o: Next
'FOR n = 0 TO nobj: ticol(27 + n * 31) = 4 * (INT(TIMER * 10 + n) AND 1): NEXT
Palette 255, 60 * (Int(Timer * 10) And 1)
If oby(nobj) > 0 Then
If Int(Timer * 5) <> otm& Then oby(nobj) = oby(nobj) - 1: otm& = Int(Timer * 5)
Else
ticol(ntri) = 6: hiticol(ntri) = &H600
End If
End Sub
Function tileside (pt, tile)
Dim ts, pb
ts = 1: For p = 0 To 3: If pt = tipt(p, tile) Then ts = 0: Exit For
Next
If ts Then
pb = tipt(0, tile)
ts = Sgn((rtx(pt) - rtx(pb)) * tnx(tile) + (rty(pt) - rty(pb)) * tny(tile) + (rtz(pt) - rtz(pb)) * tnz(tile))
End If
tileside = ts
End Function
Sub timeit
Static fram, ofram, otim!
If Not tog(0) Then Wait 986, 8
fram = fram + 1:
If Timer - otim! >= 1 Then
ofram = fram: Locate 1, 6: Print fram; " ": otim! = Timer: fram = 0
End If
End Sub
Sub TLINEFRx (pp1, pp2)
Dim den As Long, num As Long, ymin As Long, ymax As Long
p1 = pp1: p2 = pp2: ymin = yy(p1): ymax = yy(p2)
If ymin > ymax Then Swap ymin, ymax: Swap p1, p2
If ymax < scrtop Or ymin > scrbot Then Exit Sub
If ymax > scrbot Then ymax = scrbot
If ymin < scrtop Then ymin = scrtop
den = yy(p2) - yy(p1)
If den <> 0 Then
num = xx(p2) - xx(p1)
If num = 0 Then
sxx = xx(p1): For y% = ymin To ymax
If sxx > trrt(y%) Then trrt(y%) = sxx - 1
If sxx < trlft(y%) Then trlft(y%) = sxx
Next
Else
For y% = ymin To ymax: sxx = xx(p1) + (num * (y% - yy(p1))) \ den
If sxx > trrt(y%) Then trrt(y%) = sxx - 1
If sxx < trlft(y%) Then trlft(y%) = sxx
Next
End If
Else
xmin = xx(p1): xmax = xx(p2): If xmin > xmax Then Swap xmin, xmax
If xmax < 0 Or xmin > sright Then Exit Sub
If xmax > sright Then xmax = sright
If xmin < 0 Then xmin = 0
If xmin < trlft(ymin) Then trlft(ymin) = xmin
If xmax > trrt(ymin) Then trrt(ymin) = xmax
End If
If ymin < trymin Then trymin = ymin
If ymax > trymax Then trymax = ymax
End Sub
DefLng X-Z
Sub TLINESIDEx (p1, p2, p3): 'know this: pz(p1)>0
delx! = px(p2) * pz(p1) - px(p1) * pz(p2)
dely! = -(py(p2) * pz(p1) - py(p1) * pz(p2))
If pz(p2) > 0 Then
ymin = yy(p1): ymax = yy(p2): If ymin > ymax Then Swap ymin, ymax
Else
ymin = yy(p1): ymax = ymin
If dely! > 0 Then ymax = scrbot Else If dely! < 0 Then ymin = scrtop
End If
If ymax < scrtop Or ymin > scrbot Then Exit Sub
If ymax > scrbot Then ymax = scrbot
If ymin < scrtop Then ymin = scrtop
delx3! = px(p3) * pz(p1) - px(p1) * pz(p3)
dely3! = -(py(p3) * pz(p1) - py(p1) * pz(p3))
xside = -Sgn(dely!) * Sgn(delx! * dely3! - delx3! * dely!)
If pz(p2) > 0 Then
dely! = yy(p2) - yy(p1): delx! = xx(p2) - xx(p1)
Else
delx! = delx! * scr
End If
If CLng(dely!) <> 0 And ymax > ymin Then
slp! = delx! / dely!: diff& = slp! * (ymax - ymin)
sxx1& = xx(p1) + CLng(slp! * (ymin - yy(p1)))
For y% = ymin To ymax: 'sxx& = xx(p1) + CLNG(slp! * (y% - yy(p1)))
sxx& = sxx1& + (diff& * (y% - ymin)) \ (ymax - ymin)
If xside = -1 Then
trrt(y%) = sxx&: inrt(y%) = 0
If inlft(y%) = -1 Then trlft(y%) = 0: inlft(y%) = 0
Else 'IF xside = 1 THEN
trlft(y%) = sxx&: inlft(y%) = 0
If inrt(y%) Then trrt(y%) = sright: inrt(y%) = 0
End If
Next
Else
'ymax = ymin; horizontal line: '...
If pz(p2) > 0 Then
xmin = xx(p1): xmax = xx(p2): If xmin > xmax Then Swap xmin, xmax
Else
xmin = xx(p1): xmax = xmin
If delx! > 0 Then xmax = sright Else If delx! < 0 Then xmin = 0
End If
If xmax < 0 Or xmin > sright Then Exit Sub
If xmax > sright Then xmax = sright
If xmin < 0 Then xmin = 0
trlft(ymin) = xmin: trrt(ymin) = xmax: inlft(ymin) = 0: inrt(ymin) = 0
End If
If ymin < trymin Then trymin = ymin
If ymax > trymax Then trymax = ymax
End Sub
DefInt X-Z
Sub urangle
'left handed
'dir relative to observer - normal vector - component in unrotated frame
znx! = Sin(phi!)
znz! = Cos(phi!)
xnx! = znz!
xnz! = -znx!
ptx(-1) = pvx: pty(-1) = pvy: ptz(-1) = pvz
'FOR i = 0 TO nactpt
For o = 1 To nobj:
xox! = Cos(obphi(o) * pi! / 180)
xoz! = Sin(obphi(o) * pi! / 180)
For i = op1(o) To opend(o)
ppx! = ptx(i) * xox! + ptz(i) * xoz! + obx(o) - pvx
ppz! = ptz(i) * xox! - ptx(i) * xoz! + obz(o) - pvz
rtz(i) = ppx! * znx! + ppz! * znz!
rtx(i) = ppx! * xnx! + ppz! * xnz!
rty(i) = pty(i) + oby(o) - pvy
If CInt(rtz(i)) > 0 Then
rtxx(i) = CLng(cx + (rtx(i) * scx) / rtz(i))
rtyy(i) = CLng(cy - (rty(i) * scy) / rtz(i))
End If
Next: Next
End Sub
Sub yourmove
Locate 1, 10: Print Int(phi! * 180 / pi!); pvx; pvy; pvz
If MULTIKEY(56) Then
If MULTIKEY(77) Then
pvx = pvx + xnx! * 8: pvy = pvy + xny! * 8: pvz = pvz + xnz! * 8
End If
If MULTIKEY(75) Then
pvx = pvx - xnx! * 8: pvy = pvy - xny! * 8: pvz = pvz - xnz! * 8
End If
Else
If MULTIKEY(77) Then phi! = phi! + pi! / 180
If MULTIKEY(75) Then phi! = phi! - pi! / 180
End If
If MULTIKEY(72) Then
pvx = pvx + znx! * 8: pvy = pvy + zny! * 8: pvz = pvz + znz! * 8
End If
If MULTIKEY(80) Then
pvx = pvx - znx! * 8: pvy = pvy - zny! * 8: pvz = pvz - znz! * 8
End If
If MULTIKEY(30) Then
pvy = pvy + 8
End If
If MULTIKEY(44) Then
pvy = pvy - 8
End If
End SubSomething fairly recent: A sort of pathfinding demo, PATH5.BAS. There are two targets and ten starting points at each frame. Space to exit, other key for a new map.
Code: (Select All)
'$lang: "qb"
DEFINT A-Z: DECLARE SUB putbox (x, y, c) : DIM SHARED qbver, scale, xmax, ymax
DECLARE FUNCTION testline (olx, oly, x, y) '/' Multi-line comment = FreeBasic
Screen 13: Circle (2, 2), 2: If Point(1, 0) Then qbver = 45 Else qbver = 64 '/
Dim Shared xti(7), yti(7), nbd, cbd, togl, stx, sty, tgx, tgy
scale = 1: xmax = 640 / scale - 1: ymax = 480 / scale - 1
If qbver = 45 Or qbver = 64 Then xmax = 320 / scale - 1: ymax = 200 / scale - 1
If qbver = 0 Then Screen 18
'If qbver = 64 Then _FullScreen
ReDim Shared cbordx(1, xmax / 10 * ymax), cbordy(1, xmax / 10 * ymax)
Randomize Timer: xti(0) = -1: xti(1) = 1: yti(2) = -1: yti(3) = 1
xti(4) = -1: yti(4) = -1: xti(5) = 1: yti(5) = -1
xti(6) = -1: yti(6) = 1: xti(7) = 1: yti(7) = 1
10 Cls: ReDim Shared map(xmax, ymax), pathd(xmax, ymax)
npass = 0: nbd = 0: cbd = 0
For x = 0 To xmax: For y = 0 To ymax
If x = 0 Or y = 0 Or x = xmax Or y = ymax Then map(x, y) = -1
Next: Next
For i = 1 To 40: x0 = Int(Rnd * xmax): y0 = Int(Rnd * ymax)
Select Case (Rnd > .5)
Case 0: For x = x0 To x0 + Rnd * 20 * xmax / 64: If x > xmax Then Exit For
map(x, y0) = -1: Next
Case -1: For y = y0 To y0 + Rnd * 20 * ymax / 40: If y > ymax Then Exit For
map(x0, y) = -1: Next
End Select: Next
For i = 1 To 2: Do: x = Int(Rnd * xmax): y = Int(Rnd * ymax)
Loop Until map(x, y) = 0 And pathd(x, y) = 0
tgx = x: tgy = y: Call putbox(tgx, tgy, 4): pathd(tgx, tgy) = 1: Next
For x = 0 To xmax: For y = 0 To ymax
If map(x, y) Then Call putbox(x, y, 15)
If pathd(x, y) = 1 Then
For i = 0 To 3: xt = x + xti(i): yt = y + yti(i)
If map(xt, yt) = 0 Then
cbd = cbd + 1: cbordx(0, cbd) = xt: cbordy(0, cbd) = yt
Call putbox(xt, yt, 4): 'WAIT &H3DA, 8
End If
Next
End If
Next: Next
tim# = Timer: togl = 1
Do: change = 0: npass = npass + 1: Locate 1, 1: Print npass,
togl = 1 - togl: togn = 1 - togl: numi = 3 + 4 * togl
Do While cbd > 0: x = cbordx(togl, cbd): y = cbordy(togl, cbd)
If map(x, y) = 0 And pathd(x, y) = 0 Then
'IF map(x, y) OR pathd(x, y) = 0 THEN
For i = 0 To numi: xt = x + xti(i): yt = y + yti(i)
If pathd(xt, yt) Then
If pathd(x, y) = 0 Or pathd(x, y) > pathd(xt, yt) + 1 Then
pathd(x, y) = pathd(xt, yt) + 1: change = 1: Call putbox(x, y, pathd(x, y))
'pset (x, y), pathd(x, y)
End If
ElseIf map(xt, yt) = 0 Then
nbd = nbd + 1: cbordx(togn, nbd) = xt: cbordy(togn, nbd) = yt: 'map(xt, yt) = 1
End If: Next
End If: cbd = cbd - 1: Loop: cbd = nbd: nbd = 0
Loop Until change = 0 'OR pathd(stx, sty) > 0
For s = 1 To 10
Do: x = Int(Rnd * xmax): y = Int(Rnd * ymax): Loop Until map(x, y) = 0
stx = x: sty = y: Call putbox(x, y, 1): olx = x: oly = y: ovy = 1000: ochg = 0: count = 0
If pathd(stx, sty) > 0 Then
Do: np = pathd(x, y): nx = x: ny = y: chg = 0: count = count + 1: For i = 0 To 7
xt = x + xti(i): yt = y + yti(i)
If pathd(xt, yt) > 0 And pathd(xt, yt) < pathd(nx, ny) Then nx = xt: ny = yt
'If map(xt, yt) = -1 Or pathd(x, y) = 2 Then chg = 1
Next: If pathd(x, y) = 2 Then chg = 1
vx = nx - x: vy = ny - y: oox = oldx: ooy = oldy: oldx = x: oldy = y
x = nx: y = ny: 'Call putbox(x, y, s + 1): 'oox = olx: ooy = oly
chg = chg + testline(olx, oly, x, y): 'Circle (olx, oly), 4, 3
If count > 1000 Then x = nx: y = ny
If (x = oldx And y = oldy) Or (x = oox And y = ooy) Then x = nx: y = ny: chg = 1
If chg > 0 And (ovx <> vx Or ovy <> vy) Then
' If chg > 0 Then
ovx = vx: ovy = vy: ochg = chg
Line (olx * scale, oly * scale)-(x * scale, y * scale), s:
olx = x: oly = y: 'Circle (olx, oly), 4, 3
End If
'Locate 2, 1: Print x, y, vx, vy
Loop Until pathd(x, y) = 1
Line (olx * scale, oly * scale)-(x * scale, y * scale), s: Call putbox(x, y, 4)
End If: Next
'to do: keep track of wall breach starts; draw line between last good positions
Print Timer - tim#: Sleep
If InKey$ <> " " Then 10
Sub putbox (x, y, c)
Line (x * scale, y * scale)-((x + 1) * scale - 1, (y + 1) * scale - 1), c, BF
End Sub
Function testline (olx, oly, x, y)
x1 = olx: x2 = x: y1 = oly: y2 = y: tsl = 0
delx = x - olx: dely = y - oly
'If delx <> 0 And dely <> 0 Then Call putbox(x, y, 6): Call putbox(olx, oly, 5)
If Abs(delx) >= Abs(dely) And delx <> 0 Then
If x1 > x2 Then Swap x1, x2: Swap y1, y2
For xx = x1 To x2: yy = y1 + dely * (xx - x1) / delx
'If delx <> 0 And dely <> 0 Then Line (x, y)-(olx, oly), 6
'Call putbox(xx, yy, 4)
'If map(xx, yy) = -1 Then tsl = 1: Exit For
For i = 0 To 7
xt = xx + xti(i): yt = yy + yti(i)
If map(xt, yt) = -1 Then tsl = 1
Next: If tsl = 1 Then Exit For
Next
ElseIf dely <> 0 Then
If y1 > y2 Then Swap x1, x2: Swap y1, y2
For yy = y1 To y2: xx = x1 + delx * (yy - y1) / dely
'If delx <> 0 And dely <> 0 Then Line (x, y)-(olx, oly), 6
'Call putbox(xx, yy, 4)
'If map(xx, yy) = -1 Then tsl = 1: Exit For
For i = 0 To 7
xt = xx + xti(i): yt = yy + yti(i)
If map(xt, yt) = -1 Then tsl = 1
Next: If tsl = 1 Then Exit For
Next
End If
If tsl = 1 And map(xx, yy) = 0 And (xx <> olx Or yy <> oly) Then x = xx: y = yy: 'Circle (xx, yy), 4, 4
'If tsl = 1 Then Circle (xx, yy), 4, 4: 'Print xx; yy; "c"
testline = tsl
End Function