Login

kinem · (This post was last modified: 04-18-2022, 01:30 AM by kinem.)

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

johnno56 · 04-18-2022, 01:21 AM

Cool game... Unfortunately, my playing skills are not what they used to be.... lol

kinem · 04-20-2022, 02:52 AM

(04-18-2022, 01:21 AM)johnno56 Wrote: Cool game... Unfortunately, my playing skills are not what they used to be.... lol

Thanks. Let me know if you have suggestions.

***Pete*** · 04-20-2022, 03:25 AM

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

kinem · 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 = a

3D-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 Sub

Something 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

James D Jarvis · 04-26-2022, 12:59 PM

It was fun and worked smoothly. Definitely needs a level builder or randomizer.

kinem · 04-28-2022, 12:33 AM

Thanks. I might add that. In the meantime, it shouldn't be hard to modify the level in the code.

Login
Username/Email:
Password:	Lost Password?
	Remember me