Collision multiple balls
#21
Thee Second Amendment gives him thee right to "bare" arms. It's what he does with his other gun ya should be worried about.

- Sam Angry
Reply
#22
(02-11-2018, 01:07 PM)codeguy Wrote:
Code:
'* drawpoly3dcollideshaderotatefindcentroid.bas
'* now featuring an even LONGER name, but that's what this does.
'* with this version, i have added rotations in all 3 planes for a neat-o effect! if not for hairxxx's shading algo and my octree variant collision
'* detection algo, this would be HORRENDOUSLY slow past 30 or so objects. however, this is the best combination of speed and coolness i could
'* come up with. Thanks to HairXXX for his fast polyshader. this is the best demo i could come up with to demonstrate several principles, namely
'* how to draw, rotate and collision check stuff in real-time. i make the disclaimer that collision checking may fail on very rare occasions or under
'* some circumstances, so use this for entertainment purposes only. thanks to Zom-B for screen mode selector! and thanks to me for whatever it is i
'* think i might have done.

'* this is MY modification of Zom-B's modification, so i guess this makes it a mod-mod! my newly corrected and i think correctly working collision
'* code -- correct in that no poly pass-throughs occur, although they might entangle. thanks for the inspiration, zom-b, hairxxx and others!
'* this version now features Zom-B's screen mode selector and i suppose if i wanted to make this into a frankenbeast (although an entertaining one
'* at that), i could put clippy's _FILES$ routine in here too!
'* now featuring the centroid algo thanks to dick, whatever his last name  may be!
'* press the spacebar or left mouse button for a cool little "fountain" effect of sorts.
'* Rendered in REAL-TIME, with NO get/put
RANDOMIZE TIMER
DEFINT A-Z
CONST MaxPolys = 191
CONST asteroid = 0
CONST laserbomb = 1
CONST ismyship = 2
DIM SHARED CenterScreenX, CenterScreenY

'*************** Zom-B's famous (at least on qb64.net) screen mode selector!
DIM SHARED maxscreenx, maxscreeny, maxscreenz
_FULLSCREEN
WIDTH , 36
maxscreenx = _DESKTOPWIDTH
maxscreeny = _DESKTOPHEIGHT
ncolors = 32
SCREEN _NEWIMAGE(maxscreenx, maxscreeny, ncolors)
CenterScreenX = _WIDTH / 2
CenterScreenY = _HEIGHT / 2
_TITLE "Rotating Polys Using Gradient Triangle And Lines From Center of screen to object centroid * rendered in real-time no get or put. press mouse button or space bar for cool effect, esc to exit"

DIM SHARED minX%(0 TO _HEIGHT - 1)
DIM SHARED maxX%(0 TO _HEIGHT - 1)
DIM SHARED minR!(0 TO _HEIGHT - 1)
DIM SHARED maxR!(0 TO _HEIGHT - 1)
DIM SHARED minG!(0 TO _HEIGHT - 1)
DIM SHARED maxG!(0 TO _HEIGHT - 1)
DIM SHARED minB!(0 TO _HEIGHT - 1)
DIM SHARED maxB!(0 TO _HEIGHT - 1)

'************************ for experimental collision detection algo
DIM SHARED DivSecX, DivSecY, DivSecZ, NumXSegs, NumYSegs, NumZSegs, MinObjectRotateXYZ%, MaxObjectRotateRateXYZ%, MaxR
DIM SHARED currentplayerx, currentplayery, currentplayerz
NumYSegs = 16
NumXSegs = 16
NumZSegs = 16
maxscreenz = 1024
DivSecY = _HEIGHT / NumYSegs
DivSecX = _WIDTH / NumXSegs
DivSecZ = maxscreenz / NumZSegs

'* this is just an arbitrary formula i came up with that keeps counts() and polysinregion() from having array bounds errors
'* there is probably a better one available, but this involves a lot of probability theory
ProbableMax = 2 * MaxPolys / ((NumXSegs + 1) ^ (1 / 8))

DIM SHARED Counts(NumXSegs, NumYSegs, NumZSegs), PolysInRegion(NumXSegs, NumYSegs, NumZSegs, ProbableMax)

'*************************
TYPE PolyRec
    px AS INTEGER
    py AS INTEGER
    pz AS INTEGER
    radius AS INTEGER
    nsides AS INTEGER
    incx AS INTEGER
    incy AS INTEGER
    incz AS INTEGER
    rotateangle AS INTEGER
    incrotate AS INTEGER
    vertical AS INTEGER
    horizontal AS INTEGER
    verticalinc AS INTEGER
    horizontalinc AS INTEGER
    fill AS INTEGER
    fillstep AS INTEGER
    dosectorlines AS INTEGER
    cr AS SINGLE
    cg AS SINGLE
    cb AS SINGLE
    crs AS SINGLE
    cgs AS SINGLE
    cbs AS SINGLE
    mass AS INTEGER
    alreadychecked AS INTEGER
    style AS INTEGER
    kind AS INTEGER
    active AS INTEGER
END TYPE
k! = 2520
'2^3 * 3^2 * 5 * 7 = 2520, a number dividable by all numbers between 1 and 10.
DIM SHARED SinTable!(0 TO k! - 1), CosTable!(0 TO k! - 1), UpBoundTrigTables%, mybulletmin, mybulletmax, myship, points&

UpBoundTrigTables% = UBOUND(SinTable!)
MaxObjectRotateRateXYZ% = (UpBoundTrigTables% + 1) / 8
MinObJectRotateRateXYZ% = (UpBoundTrigTables% + 1) / 15
'* use precalculated trig tables for speed, especially doing rotations!
'* this program does a ton of them
FOR i = 0 TO UpBoundTrigTables%
    a! = i * 3.141592653589793 / ((UpBoundTrigTables% + 1) / 2)
    SinTable!(i) = SIN(a!)
    CosTable!(i) = COS(a!)
NEXT
keystepx = maxscreenx / 10
keystepy = maxscreeny / 10
keystepz = maxscreenz / 10
DIM Polys(MaxPolys) AS PolyRec

IF DivSecX < DivSecY THEN
    MaxR = DivSecX
ELSE
    MaxR = DivSecY
END IF
IF DivSecZ < MaxR THEN
    MaxR = DivSecZ
END IF

'* user-controlled poly -- still a bit jumpy to say the least, even with loop-unrolled (formerly the for/next with index i on polygons)
'* program a faster way to handle this and add some shooting/effects, you got yourself a game!
myship = 0
numbullets = 32
mybulletmin = myship + 1
mybulletmax = mybulletmin + numbullets
'* set default values for stuff flying around on-screen
'* must pass i as this determines the classification of the polygon
'* far easier to do this than creating individual polygon records for the ship, its weapons (laserbombs) and each asteroid (polyoid)
FOR i = 0 TO MaxPolys
    setPolyParams Polys(), i
NEXT
nframes% = 0
frames& = 0
tstart# = TIMER
Bytes% = (DivSecX * DivSecY * (32 / 8) + 4) / 2
DIM RestoreScreen%(DivSecX, DivSecY, 1 TO Bytes%)
oldpx = -1
oldpy = -1
asteroidhit = 0
_MOUSEHIDE

'* change this to 0 for making into game
testing = -1
IF testing THEN
    up$ = CHR$(0) + CHR$(72) '* up arrow
    down$ = CHR$(0) + CHR$(80) '* down arrow
    lft$ = CHR$(0) + CHR$(75) '* left arrow
    rght$ = CHR$(0) + CHR$(77) '* right arrow
    back$ = CHR$(0) + CHR$(141) '* ctrl-up
    forward$ = CHR$(0) + CHR$(145) '*ctrl-down
    fire$ = " "
    fdx$ = "X"
    fdy$ = "Y"
    fdz$ = "Z"
    fdxn$ = "^X"
    fdyn$ = "^Y"
    fdzn$ = "^Z"
    cutthatcrapout$ = CHR$(27)
ELSE
    GetKey "Up", up$
    GetKey "Down", down$
    GetKey "Left", lft$
    GetKey "Right", rght$
    GetKey "forward", forward$
    GetKey "Back", back$
    GetKey "Fire", fire$
    GetKey "Stop this infernal madness", cutthatcrapout$
    GetKey "Fire Direction X+", fdx$
    GetKey "Fire Direction Y+", fdy$
    GetKey "Fire Direction Z+", fdz$
    GetKey "Fire Direction X-", fdxn$
    GetKey "Fire Direction Y-", fdyn$
    GetKey "Fire Direction Z-", fdzn$
END IF

'_FULLSCREEN
points& = 0
asteroidhit = 0
asteroidhitmax = 256
i = MaxPolys + 1
missilesactive% = 0
nframes% = 0
DO
    frames& = frames& + 1
    DO

        DO
            lb% = _MOUSEBUTTON(1)
            IF lb% THEN
                k$ = fire$
            END IF
            rb% = _MOUSEBUTTON(2)
            IF rb% THEN '* function not yet implemented
            END IF
            currentplayerx = _MOUSEX
            currentplayery = _MOUSEY
            M% = _MOUSEINPUT
        LOOP UNTIL NOT M%
        k$ = INKEY$
        SELECT CASE k$
            CASE CHR$(1) TO CHR$(26)
                k$ = "^" + CHR$(ASC("A") - 1 + ASC(k$))
        END SELECT
        SELECT CASE k$ '* keyboard
            CASE lft$
                currentplayerx = SetToMinMax(currentplayerx - keystepx, Polys(myship).radius, maxscreenx - Polys(myship).radius)
            CASE rght$
                currentplayerx = SetToMinMax(currentplayerx + keystepx, Polys(myship).radius, maxscreenx - Polys(myship).radius)
            CASE up$
                currentplayery = SetToMinMax(currentplayery - keystepy, Polys(myship).radius, maxscreeny - Polys(myship).radius)
            CASE down$
                currentplayery = SetToMinMax(currentplayery + keystepy, Polys(myship).radius, maxscreeny - Polys(myship).radius)
            CASE forward$ '* into the screen -- increasing z values move away from player
                currentplayerz = SetToMinMax(currentplayerz + keystepz, Polys(myship).radius, maxscreenz - Polys(myship).radius)
            CASE back$
                currentplayerz = SetToMinMax(currentplayerz - keystepz, Polys(myship).radius, maxscreenz - Polys(myship).radius)
            CASE fire$
                '* the laserbombs start in a cluster and spread out fairly evenly along x,y and z planes
                '* don't fire off too many at once or my collision-checking program might scream
                '* i have fired off 64 at once without failure. for a cool effect, hold down the spacebar
                '* or whatever key you select for your fire button and then release it.
                missilesactive% = -1
                nframes% = 0
                count% = 0
                FOR h = mybulletmin TO mybulletmax
                    Polys(h).active = -1
                    Polys(h).px = currentplayerx + Polys(myship).radius
                    Polys(h).py = currentplayery + Polys(myship).radius
                    Polys(h).pz = currentplayerz + Polys(myship).radius
                    Polys(h).incx = (CINT(RND) * 2 - 1) * (INT(RND * (_HEIGHT \ 32)) + 1)
                    Polys(h).incy = (CINT(RND) * 2 - 1) * (INT(RND * (_HEIGHT \ 32)) + 1)
                    Polys(h).incz = (CINT(RND) * 2 - 1) * (INT(RND * (maxscreenz \ 32)) + 1)
                    'Polys(h).incx = 7 + INT(RND * 9)
                    'Polys(h).incy = 7 + INT(RND * 9)
                    'Polys(h).incz = 7 + INT(RND * 9)
                NEXT
                IF fdx < 1 THEN
                    fdx = 1
                END IF
                IF fdy < 1 THEN
                    fdy = 1
                END IF
                IF fdz < 1 THEN
                    fdz = 1
                END IF
                EXIT DO
            CASE fdx$
                fdx = fdx + 1
            CASE fdy$
                fdy = fdy + 1
            CASE fdz$
                fdz = fdz + 1
            CASE fdxn$ '* "^X"
                fdx = fdx - 1
            CASE fdyn$ '* "^Y"
                fdy = fdy - 1
            CASE fdzn$ '* "^Z"
                fdz = fdz - 1
            CASE cutthatcrapout$
                SYSTEM
            CASE ELSE
                mk = 0
                LOCATE 2, 1
                DO
                    IF mk < LEN(k$) THEN
                        mk = mk + 1
                        PRINT USING "###:"; ASC(k$, mk);
                    ELSE
                        EXIT DO
                    END IF
                LOOP
        END SELECT
    LOOP UNTIL k$ = ""
    DO
        IF oldpx <> currentplayerx OR oldpy <> currentplayery OR currentplayerz <> oldpz THEN
            'drawpolySimple PlayerRect, _RGB32(PlayerRect.cr, playerrrect.cg, PlayerRect.cb)
            oldpy = currentplayery
            oldpx = currentplayerx
            oldpz = currentplayerz
            'PlayerRect.px = CurrentPlayerx
            'PlayerRect.py = CurrentPlayerY
            'PlayerRect.pz = CurrentPlayerZ
        END IF
        IF i > MaxPolys THEN
            _DISPLAY
            PrintLocate 3, 1, MID$(STR$(points&, 2), 1, 0, 0, dummy$
            oldpx = currentplayerx - 1
            oldpy = currentplayery - 1
            i = 0
            FOR X = 0 TO NumXSegs
                FOR y = 0 TO NumYSegs
                    FOR z = 0 TO NumZSegs
                        FOR a = 0 TO Counts(X, y, z) - 1
                            Polys(PolysInRegion(X, y, z, a)).alreadychecked = 0
                        NEXT
                        Counts(X, y, z) = 0
                    NEXT
                NEXT
            NEXT
            EXIT DO
        ELSE
            'drawpoly Polys(i), 0
            SELECT CASE Polys(i).kind
                CASE ismyship
                    Polys(i).px = currentplayerx
                    Polys(i).py = currentplayery
                    Polys(i).pz = currentplayerz
                CASE ELSE
                    IF Polys(i).px > maxscreenx - Polys(i).incx - Polys(i).radius THEN
                        Polys(i).incx = -Polys(i).incx
                        Polys(i).incrotate = -SGN(Polys(i).incy) * RandRange%(MinObJectRotateRateXYZ%, MaxObjectRotateRateXYZ%)
                    ELSEIF Polys(i).px < Polys(i).radius - Polys(i).incx THEN
                        Polys(i).incx = -Polys(i).incx
                        Polys(i).incrotate = SGN(Polys(i).incy) * RandRange%(MinObJectRotateRateXYZ%, MaxObjectRotateRateXYZ%)
                    END IF

                    IF Polys(i).py > maxscreeny - Polys(i).incy - Polys(i).radius THEN
                        Polys(i).incy = -Polys(i).incy
                        Polys(i).incrotate = SGN(Polys(i).incx) * RandRange%(MinObJectRotateRateXYZ%, MaxObjectRotateRateXYZ%)
                    ELSEIF Polys(i).py < Polys(i).radius - Polys(i).incy THEN
                        Polys(i).incy = -Polys(i).incy
                        Polys(i).incrotate = -SGN(Polys(i).incx) * RandRange%(MinObJectRotateRateXYZ%, MaxObjectRotateRateXYZ%)
                    END IF

                    IF Polys(i).pz > maxscreenz - Polys(i).incz - Polys(i).radius THEN
                        Polys(i).incz = -Polys(i).incz
                        Polys(i).incrotate = SGN(Polys(i).incx) * RandRange%(MinObJectRotateRateXYZ%, MaxObjectRotateRateXYZ%)
                    ELSEIF Polys(i).pz < Polys(i).radius - Polys(i).incz THEN
                        Polys(i).incz = -Polys(i).incz
                        Polys(i).incrotate = -SGN(Polys(i).incz) * RandRange%(MinObJectRotateRateXYZ%, MaxObjectRotateRateXYZ%)
                    END IF
            END SELECT
            '* SetIncrementers Polys(i).px, Polys(i).incx, Polys(i).radius, Maxscreenx - Polys(i).radius
            '* SetIncrementers Polys(i).py, Polys(i).incy, Polys(i).radius, Maxscreeny - Polys(i).radius
            '* SetIncrementers Polys(i).pz, Polys(i).incz, Polys(i).radius, MaxScreenZ - Polys(i).radius

            SetIncrementers Polys(i).cr, Polys(i).crs, 0, 255
            SetIncrementers Polys(i).cg, Polys(i).cgs, 0, 255
            SetIncrementers Polys(i).cb, Polys(i).cbs, 0, 255

            Polys(i).horizontal = MapToTrigTables%(Polys(i).horizontal + Polys(i).horizontalinc)
            Polys(i).vertical = MapToTrigTables%(Polys(i).vertical + Polys(i).verticalinc)
            Polys(i).rotateangle = MapToTrigTables%(Polys(i).rotateangle + Polys(i).incrotate)

            Polys(i).px = Polys(i).px + Polys(i).incx
            Polys(i).py = Polys(i).py + Polys(i).incy
            Polys(i).pz = Polys(i).pz + Polys(i).incz

            Polys(i).cr = Polys(i).cr + Polys(i).crs
            Polys(i).cg = Polys(i).cg + Polys(i).cgs
            Polys(i).cb = Polys(i).cb + Polys(i).cbs
            IF Polys(i).active THEN
                drawpoly Polys(i), 1

                getsegminmax Polys(i).px, StartX, EndX, Polys(i).radius, IndexX, DivSecX, NumXSegs
                getsegminmax Polys(i).py, StartY, EndY, Polys(i).radius, IndexY, DivSecY, NumYSegs
                getsegminmax Polys(i).pz, StartZ, EndZ, Polys(i).radius, IndexZ, DivSecZ, NumZSegs

                PolysInRegion(IndexX, IndexY, IndexZ, Counts(IndexX, IndexY, IndexZ)) = i
                Polys(PolysInRegion(IndexX, IndexY, IndexZ, i)).alreadychecked = -1
                FOR sx = StartX TO EndX
                    FOR sy = StartY TO EndY
                        FOR sz = StartZ TO EndZ
                            FOR z = 0 TO Counts(sx, sy, sz) - 1
                                GOSUB MainCollider
                            NEXT
                        NEXT
                    NEXT
                NEXT
                Counts(IndexX, IndexY, IndexZ) = Counts(IndexX, IndexY, IndexZ) + 1
                'PutRegion Polys(i), IndexX, IndexY, RestoreScreen%()
            ELSE
                'drawpoly Polys(i), 0
            END IF
            i = i + 1
            IF missilesasctive% THEN
                IF count% > MaxPolys% THEN
                    IF nfames% < 64 THEN
                        nframes% = nframes% + 1
                    ELSE
                        IF testing THEN
                        ELSE
                            '* LOCATE 2, 1
                            '* PRINT "Ha! You missed us, James T Kirk -- you suck!";
                        END IF
                        FOR h = mybulletmin TO mybulletmax
                            '* drawpoly Polys(h), 0
                            Polys(h).active = 0
                        NEXT
                        count% = 0
                        nframes% = 0
                        missilesactive% = 0
                    END IF
                ELSE
                    count% = count% + 1
                END IF
            END IF
        END IF
    LOOP
    '_LIMIT 60
    _DISPLAY
    IF k$ = CHR$(27) THEN
        EXIT DO
    ELSE
        CLS
        IF frames& MOD 1000 = 0 THEN
            '_TITLE STR$(frames& / 1000) + STR$(frames& / (TIMER - tstart#))
        END IF
        'saveimage _DEST, "ScreenShot" + STR$(frame& / 1000)
        'SYSTEM
    END IF
    _LIMIT 30
LOOP
tend# = TIMER
PRINT frames& / (tend# - tstart#)
_MOUSESHOW
SYSTEM

MainCollider:
IF PolysInRegion(sx, sy, sz, i) <> PolysInRegion(sx, sy, sz, z) THEN
    collide Polys(), PolysInRegion(sx, sy, sz, i), PolysInRegion(sx, sy, sz, z)
    IF Distance(Polys(PolysInRegion(sx, sy, sz, i)), Polys(PolysInRegion(sx, sy, sz, z))) <= 0 THEN
        SELECT CASE Polys(PolysInRegion(sx, sy, sz, i)).kind
            CASE asteroid
                IF Polys(PolysInRegion(sx, sy, sz, z)).kind = laserbomb THEN
                    '* asteroid smacked bomb
                    Polys(PolysInRegion(sx, sy, sz, z)).active = 0
                    Polys(PolysInRegion(sx, sy, sz, i)).active = 0
                    points& = points& + 1
                END IF
            CASE laserbomb
                IF Polys(PolysInRegion(sx, sy, sz, z)).kind = asteroid THEN
                    '* bomb smacked asteroid
                    Polys(PolysInRegion(sx, sy, sz, z)).active = 0
                    Polys(PolysInRegion(sx, sy, sz, i)).active = 0
                    IF testing THEN
                    ELSE
                        points& = points& + 1
                        IF testing THEN
                        ELSE

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                            '* PointDsp$ = "Holy Klingon! -- They sank our battleship (" + MID$(STR$(points&, 2) + ")"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

                            '* LOCATE 2, 1
                            '* PRINT PointDsp$;
                        END IF
                    END IF
                END IF
            CASE ismyship
                IF Polys(PolysInRegion(sx, sy, sz, z)).kind = asteroid THEN
                    '* asteroid smacked my ship
                    IF asteroidhit < asteroidhitmax THEN
                        asteroidhit = asteroidhit + 1
                    ELSE
                        points& = points& - 1
                        asteroidhit = 0
                    END IF
                END IF
        END SELECT
    END IF
END IF
RETURN

SUB setPolyParams (p() AS PolyRec, i)
p(i).radius = INT(((MaxR - 2) / 1.28) * RND) + 2
p(i).px = INT(RND * (maxscreenx - 2 * p(i).radius)) + p(i).radius
p(i).py = INT(RND * (maxscreeny - 2 * p(i).radius)) + p(i).radius
p(i).pz = INT(RND * (maxscreenz - 2 * p(i).radius)) + p(i).radius
p(i).nsides = INT(RND * 7) + 2
IF p(i).nsides = 2 THEN p(i).nsides = 40 'approximate circle
p(i).incx = (CINT(RND) * 2 - 1) * (INT(RND * (_HEIGHT \ 32)) + 1)
p(i).incy = (CINT(RND) * 2 - 1) * (INT(RND * (_HEIGHT \ 32)) + 1)
p(i).incz = (CINT(RND) * 2 - 1) * (INT(RND * (maxscreenz \ 32)) + 1)
p(i).rotateangle = RangeNum%(MinObjectRotateXYZ%, MaxObjectRotateRateXYZ%)
p(i).incrotate = (CINT(RND) * 2 - 1) * RandRange%(MinObJectRotateRateXYZ%, MaxObjectRotateRateXYZ%)

'* these are used by drawpolySimple
p(i).fill = CINT(RND) * 2 - 1
p(i).fillstep = INT(RND * MaxR) + 1
p(i).style = INT(RND * 3)
p(i).dosectorlines = INT(1 - RND * 2)
p(i).vertical = (CINT(RND) * 2 - 1) * RangeNum%(MinObjectRotateXYZ%, MaxObjectRotateRateXYZ%)
p(i).horizontal = (CINT(RND) * 2 - 1) * RangeNum%(MinObjectRotateXYZ%, MaxObjectRotateRateXYZ%)
p(i).verticalinc = (CINT(RND) * 2 - 1) * RangeNum%(MinObjectRotateXYZ%, MaxObjectRotateRateXYZ%)
p(i).horizontalinc = (CINT(RND) * 2 - 1) * RangeNum%(MinObjectRotateXYZ%, MaxObjectRotateRateXYZ%)
'Color cycling
p(i).cr = RND * 256
p(i).cg = RND * 256
p(i).cb = RND * 256
p(i).crs = (CINT(RND) * 2 - 1) * (RND * 4 + 2)
p(i).cgs = (CINT(RND) * 2 - 1) * (RND * 4 + 2)
p(i).cbs = (CINT(RND) * 2 - 1) * (RND * 4 + 2)

'* these are used by collision checker
p(i).mass = 1 '(Polys(i).radius ^ 3) / 4
p(i).alreadychecked = 0
p(i).active = -1
SELECT CASE i
    CASE myship
        p(i).kind = ismyship
        p(i).incx = 0
        p(i).incy = 0
        p(i).incz = 0
        p(i).radius = MaxR
        IF _MOUSEINPUT THEN
            currentplayerx = _MOUSEX
            currentplayery = _MOUSEY
        END IF
        p(i).pz = currentplayerx
        p(i).py = currentplayery
        p(i).px = currentplayerz
        p(i).incrotate = (UpBoundTrigTables% + 1) / (p(i).nsides + 1)
        'P(i).verticalinc = 0
        'P(i).horizontalinc = 0
        'PlayerRect = P(i)
        'PlayerRect.radius = p(i).radius / 2
    CASE mybulletmin TO mybulletmax
        p(i).kind = laserbomb
        p(i).active = 0
        p(i).nsides = INT(RND * 7) + 3
    CASE ELSE
        p(i).kind = asteroid
END SELECT
END SUB
SUB GetKey (p$, r$)
PRINT "Press the key to go "; p$
DO
    r$ = INKEY$
LOOP UNTIL r$ > ""
END SUB

SUB getsegminmax (ptcheck, sxy, exy, radius, Index, divider, NumSegs)
'* calculates the minimum and maximum segments of collision space to look at when doing collision checking
'* far faster than the usual method of looking at all the other particles, even if they aren't in the same region of enclosed volume
'* if the particle is near an adjacent border, it will be checked against other particles in that region
Index = SetToMinMax(ptcheck \ divider, 0, NumSegs)
IF Index > 0 THEN
    sxy = (ptcheck - radius) \ divider
ELSE
    sxy = Index
END IF
IF (ptcheck + radius) \ divider > NumSegs THEN
    exy = NumSegs
ELSE
    exy = (ptcheck + radius) \ divider
END IF
END SUB

FUNCTION SetToMinMax (calcvalue, minval, maxval)
'* used to calculate rotating values, namely color variations used for shading/coloring polygons and increments used for moving asteroids/laserbombs
'* whose values are not mouse/user input dependent
IF calcvalue < minval THEN
    SetToMinMax = minval
ELSE
    IF calcvalue > maxval THEN
        SetToMinMax = maxval
    ELSE
        SetToMinMax = calcvalue
    END IF
END IF
END FUNCTION

SUB SetIncrementers (a, addv, min, max)
a = SetToMinMax(a + addv, min, max)
IF a < min - addv THEN
    addv = -addv
ELSEIF a > max - addv THEN
    addv = -addv
END IF
END SUB

SUB collide (p() AS PolyRec, x, y)
'* checks collisions between polygons or particles (0-sided,0-radius)
calcmethod = 1
SELECT CASE calcmethod
    CASE 1
        IF Distance(p(x), p(y)) > 0 THEN
            EXIT SUB
        ELSE
            CalcVelocities p(), x, y
            p(x).alreadychecked = -1
            p(y).alreadychecked = -1
        END IF
    CASE ELSE
        IF (NOT p(x).alreadychecked) OR (NOT p(y).alreadychecked) THEN
            IF ABS(p(x).pz - p(y).pz) < p(x).radius + p(y).radius THEN
                d = ((p(x).px - p(y).px) ^ 2 + (p(x).py - p(y).py) ^ 2)
                IF d <= (p(x).radius + p(y).radius) ^ 2 THEN
                    CalcVelocities p(), x, y
                    p(x).alreadychecked = -1
                    p(y).alreadychecked = -1
                END IF
            END IF
        END IF
END SELECT
END SUB

FUNCTION Distance (p AS PolyRec, q AS PolyRec)
'* calculates distance using pythagorean formula for (x1,y1), (x2,y2) and relative distance betweenz Z
dx! = (p.px - q.px) ^ 2
dy! = (p.py - q.py) ^ 2
hyp! = SQR(dx! + dy!)
IF hyp! > p.radius + q.radius THEN
    s! = hyp! - (p.radius + q.radius)
ELSE
    IF ABS(p.pz - q.pz) > p.radius + q.radius THEN
        s! = ABS(p.pz - q.pz)
    ELSE
        s! = hyp! - (p.radius + q.radius)
    END IF
END IF
Distance = s!
END FUNCTION

FUNCTION RangeNum% (min%, max%)
'* generates random number from min% to max% inclusive
RangeNum% = min% + INT(RND * (max% - min% + 1))
END FUNCTION

SUB QuickSort (p() AS PolyRec, start, finish, m$)
IF finish - start = 1 THEN
    IF GetPx(p(finish), m$) < GetPx(p(start), m$) THEN
        SWAP p(finish), p(start)
    END IF
ELSE
    IF finish - start > 1 THEN
        M = start + (finish - start + 1) \ 2
        part = GetPx(p(M), m$)
        i = start
        j = finish
        DO
            WHILE GetPx(p(i), m$) < part
                i = i + 1
            WEND
            WHILE GetPx(p(j), m$) > part
                j = j - 1
            WEND
            IF i < j THEN
                SWAP p(i), p(j)
            END IF
            i = i + 1
            j = j - 1
        LOOP UNTIL i > j
        QuickSort p(), i, finish, m$
        QuickSort p(), start, j, m$
    END IF
END IF
END SUB

FUNCTION GetPx (p AS PolyRec, m$)
SELECT CASE m$
    CASE "x"
        GetPx = p.px
    CASE "y"
        GetPx = p.py
    CASE "z"
        GetPx = p.pz
    CASE ELSE
        GetPx = 0
END SELECT
END FUNCTION

SUB CalcVelocities (b() AS PolyRec, i&, j&
temp1 = b(i&.incx
temp2 = b(j&.incx
totalMass = (b(i&.mass + b(j&.mass)
b(i&.incx = (temp1 * (b(i&.mass - b(j&.mass) + (2 * b(j&.mass * temp2)) / totalMass
b(j&.incx = (temp2 * (b(j&.mass - b(i&.mass) + (2 * b(i&.mass * temp1)) / totalMass
temp1 = b(i&.incy
temp2 = b(j&.incy
b(i&.incy = (temp1 * (b(i&.mass - b(j&.mass) + (2 * b(j&.mass * temp2)) / totalMass
b(j&.incy = (temp2 * (b(j&.mass - b(i&.mass) + (2 * b(i&.mass * temp1)) / totalMass
temp1 = b(i&.incz
temp2 = b(j&.incz
b(i&.incz = (temp1 * (b(i&.mass - b(j&.mass) + (2 * b(j&.mass * temp2)) / totalMass
b(j&.incz = (temp2 * (b(j&.mass - b(i&.mass) + (2 * b(i&.mass * temp1)) / totalMass
END SUB


SUB drawpoly (p AS PolyRec, intensity)
REDIM x(p.nsides), y(p.nsides)
cr0 = 255 * intensity
cg0 = 255 * intensity
cb0 = 255 * intensity
cr1 = p.cr * intensity
cg1 = p.cg * intensity
cb1 = p.cb * intensity

x = p.px
y = p.py
z = p.pz
r = p.radius

a! = p.rotateangle - INT(p.rotateangle / (UpBoundTrigTables% + 1)) * (UpBoundTrigTables% + 1)
sa! = (UpBoundTrigTables% + 1) / p.nsides
b = INT(a!)
x1! = CosTable!(b) * CosTable!(p.horizontal)
y1! = SinTable!(b) * SinTable!(p.vertical)
'* leastx = x
'* mostx = x
'* leasty = y
'* mosty = y
zscale! = (z / maxscreenz)
rzscale! = r * zscale!
IF x < _WIDTH / 2 THEN
    fx = x + rzscale! / 3
ELSE
    fx = x - rzscale! / 3
END IF

IF y > _HEIGHT / 2 THEN
    fy = y - rzscale! / 3
ELSE
    fy = y + rzscale! / 3
END IF

FOR a = p.nsides - 1 TO 0 STEP -1
    a! = a! + sa!
    a! = a! + (UpBoundTrigTables% + 1) * (a! >= (UpBoundTrigTables% + 1))
    b = INT(a!)
    x2! = CosTable!(b) * CosTable!(p.horizontal): x(a) = x2!
    y2! = SinTable!(b) * SinTable!(p.vertical): y(a) = y2!
    IF zscale! = 1 THEN
        SELECT CASE p.style
            CASE 1
                gTriangle fx, fy, x + (x1! * rzscale!), y + (y1! * rzscale!), x + (x2! * rzscale!), y + (y2! * rzscale!), _RGB32(cr0, cg0, cb0), _RGB32(cr1, cg1, cb1), RGBToNum(cr1, cg1, cb1)
            CASE 2
                gTriangle fx, fy, x + (x1! * r), y + (y1! * r), x + (x2! * r), y + (y2! * r), _RGB32(cr0, cg0, cb0), _RGB32(cr1, cg1, cb1), _RGB32(cr1, cg1, cb1)
            CASE ELSE
                drawpolySimple p, _RGB32(cr0, cg0, cb0)
        END SELECT
    ELSEIF zscale! <> 0 THEN
        SELECT CASE p.style
            CASE 1
                gTriangle fx, fy, x + (x1! * rzscale!), y + (y1! * rzscale!), x + (x2! * rzscale!), y + (y2! * rzscale!), _RGB32(cr0, cg0, cb0), _RGB32(cr1, cg1, cb1), RGBToNum(cr1, cg1, cb1)
            CASE 2
                gTriangle fx, fy, x + (x1! * r), y + (y1! * r), x + (x2! * r), y + (y2! * r), _RGB32(cr0, cg0, cb0), _RGB32(cr1, cg1, cb1), _RGB32(cr1, cg1, cb1)
            CASE ELSE
                drawpolySimple p, _RGB32(cr0, cg0, cb0)
        END SELECT
    END IF
    x1! = x2!
    y1! = y2!
NEXT
findCentroid x(), y(), p.nsides, x1!, y1!
LINE (x1! + p.px, y1! + p.py)-(currentplayerx, currentplayery), _RGB32(cr1, cg1, cb1)
END SUB

SUB NewPolyDraw (p AS PolyRec)
ang = 0
stp = 360 / p.nsides
deg = ATN(1) / 45
r = p.radius
x = p.px
y = p.py

DO
    x1 = y + COS(ang * deg) * r
    y1 = y + SIN(ang * deg) * r
    x2 = y + COS((ang + 5) * deg) * r
    y2 = y + SIN((ang + 5) * deg) * r
    gTriangle x, y, x1, y1, x2, y2, c1&, c2&, c2&
    ang = ang + stp
LOOP UNTIL ang > 360 - stp
END SUB

FUNCTION RGBToNum& (cr, cg, cb)
'* not used but demonstrates how 24-bit rgb is calculated
RGBToNum& = cr * 65536 + cg * 256 + cb
END FUNCTION

SUB drawpolySimple (p AS PolyRec, c)
'* vector grahics polydraw routine with simple filling routines. uses precalculated sine and cosine tables for speed
IF p.nsides > 0 THEN
    IF c = 0 THEN
        fc& = 0
    ELSE
        fc& = _RGB32(p.cr, p.cg, p.cb)
    END IF
    Zfactor! = p.pz / maxscreenz
    yx = (UpBoundTrigTables% + 1) / p.nsides
    angle2 = MapToTrigTables%(p.rotateangle)
    FOR i = 0 TO (UpBoundTrigTables% + 1) STEP yx
        angle = angle2
        angle2 = MapToTrigTables%(angle + yx)
        IF p.fill THEN
            FOR cr = 1 TO p.radius STEP p.fillstep
                x1 = p.px + Zfactor! * (cr * CosTable!(angle)) * CosTable!(MapToTrigTables%(p.horizontal))
                y1 = p.py + Zfactor! * (cr * SinTable!((angle))) * SinTable!(MapToTrigTables%(p.vertical))
                x2 = p.px + Zfactor! * (cr * CosTable!(((angle2)))) * CosTable!(MapToTrigTables%(p.horizontal))
                y2 = p.py + Zfactor! * (cr * SinTable!(((angle2)))) * SinTable!(MapToTrigTables%(p.vertical))
                LINE (x1, y1)-(x2, y2), fc&
                IF p.dosectorlines THEN
                    LINE (p.px, p.py)-(x1, y1), fc&
                END IF
            NEXT
        ELSE
            x1 = p.px + Zfactor! * (p.radius * CosTable!((angle)))
            y1 = p.py + Zfactor! * (p.radius * SinTable!((angle)))
            x2 = p.px + Zfactor! * (p.radius * CosTable!(((angle2))))
            y2 = p.py + Zfactor! * (p.radius * SinTable!(((angle2))))
            LINE (x1, y1)-(x2, y2), fc&
            IF p.dosectorlines THEN
                LINE (p.px, p.py)-(x1, y1), fc&
            END IF
        END IF
    NEXT
ELSE
    PSET (p.px, p.py), c
END IF
END SUB

FUNCTION MapToTrigTables% (angle)
'* makes sure angle is mapped correctly to precalculated sine and cosine tables
a = angle MOD (UpBoundTrigTables% + 1)
IF a < 0 THEN
    a = a + (UpBoundTrigTables% + 1)
END IF
MapToTrigTables% = a
END FUNCTION

FUNCTION CosToSinMap (angle)
'* not used
CosToSinMap = MapToTrigTables%(angle - (UpBoundTrigTables% + 1) / 4)
END FUNCTION

FUNCTION RandRange% (min%, max%)
RandRange% = min% + INT(RND * (max% - min% + 1))
END FUNCTION

'=== Make a linear gradient along the vertical axis of an edge ===
SUB gTriangle (x1%, y1%, x2%, y2%, x3%, y3%, c1&, c2&, c3&
cr1 = _RED32(c1&: cg1 = _GREEN32(c1&: cb1 = _BLUE32(c1&
cr2 = _RED32(c2&: cg2 = _GREEN32(c2&: cb2 = _BLUE32(c2&
cr3 = _RED32(c3&: cg3 = _GREEN32(c3&: cb3 = _BLUE32(c3&

minY% = y1%
maxY% = y1%
IF minY% > y2% THEN minY% = y2%
IF maxY% < y2% THEN maxY% = y2%
IF minY% > y3% THEN minY% = y3%
IF maxY% < y3% THEN maxY% = y3%

IF minY% < 0 THEN minY% = 0
IF maxY% > _HEIGHT - 1 THEN maxY% = _HEIGHT - 1

' Create a vertical gradient along each side of the triangle
FOR y% = minY% TO maxY%
    minX%(y%) = _WIDTH
    maxX%(y%) = -1
NEXT

gMark x1%, y1%, x2%, y2%, cr1%, cg1%, cb1%, cr2%, cg2%, cb2%
gMark x2%, y2%, x3%, y3%, cr2%, cg2%, cb2%, cr3%, cg3%, cb3%
gMark x3%, y3%, x1%, y1%, cr3%, cg3%, cb3%, cr1%, cg1%, cb1%

FOR y% = minY% TO maxY%
    x% = minX%(y%)
    maxX% = maxX%(y%)
    cr! = minR!(y%)
    cg! = minG!(y%)
    cb! = minB!(y%)

    D% = maxX% - x%
    crs! = (maxR!(y%) - cr!) / D%
    cgs! = (maxG!(y%) - cg!) / D%
    cbs! = (maxB!(y%) - cb!) / D%

    IF maxX% >= _WIDTH THEN maxX% = _WIDTH - 1

    IF x% < 0 THEN
        cr! = cr! - crs! * x%
        cg! = cg! - cgs! * x%
        cb! = cb! - cbs! * x%
        x% = 0
    END IF

    WHILE x% <= maxX%
        PSET (x%, y%), _RGB(CINT(cr!) AND &HFF, CINT(cg!) AND &HFF, CINT(cb!) AND &HFF)
        x% = x% + 1
        cr! = cr! + crs!
        cg! = cg! + cgs!
        cb! = cb! + cbs!
    WEND
NEXT
END SUB

'=== Make a linear gradient along the vertical axis of an edge ===
SUB gMark (x1%, y1%, x2%, y2%, cr1%, cg1%, cb1%, cr2%, cg2%, cb2%)
D% = y2% - y1%
IF y1% < y2% THEN
    x! = x1%
    y% = y1%
    cr! = cr1%
    cg! = cg1%
    cb! = cb1%
    maxY% = y2%
ELSE
    x! = x2%
    y% = y2%
    cr! = cr2%
    cg! = cg2%
    cb! = cb2%
    maxY% = y1%
END IF

sx! = (x2% - x1%) / D%
crs! = (cr2% - cr1%) / D%
cgs! = (cg2% - cg1%) / D%
cbs! = (cb2% - cb1%) / D%

IF maxY% >= _HEIGHT THEN maxY% = _HEIGHT - 1

IF y% < 0 THEN
    x! = x! - sx! * y%
    cr! = cr! - crs! * y%
    cg! = cg! - cgs! * y%
    cb! = cb! - cbs! * y%
    y% = 0
END IF

WHILE y% <= maxY%
    x% = CINT(x!)
    IF minX%(y%) > x% THEN
        minX%(y%) = x%
        minR!(y%) = cr!
        minG!(y%) = cg!
        minB!(y%) = cb!
    END IF
    IF maxX%(y%) < x% THEN
        maxX%(y%) = x%
        maxR!(y%) = cr!
        maxG!(y%) = cg!
        maxB!(y%) = cb!
    END IF
    y% = y% + 1
    x! = x! + sx!
    cr! = cr! + crs!
    cg! = cg! + cgs!
    cb! = cb! + cbs!
WEND
END SUB

SUB GetRegion (p AS PolyRec, ix, iy, pic%())
'* my failed attempt at capturing a screen region so only regions of screen have to be redrawn
x1 = SetToMinMax(p.px - p.radius, p.radius, _WIDTH - p.radius)
y1 = SetToMinMax(p.py - p.radius, p.radius, _HEIGHT - p.radius)
x2 = SetToMinMax(p.px + p.radius, x1 + p.radius, _WIDTH - p.radius)
y2 = SetToMinMax(p.py + p.radius, y1 + p.radius, _HEIGHT - p.radius)
GET (x, y)-(x + p.radius, y + p.radius), pic%(ix, iy, 1)
'GET (x, y)-STEP(2 * p.radius, 2 * p.radius), pic%(ix,iy,1)
END SUB

SUB PutRegion (p AS PolyRec, ix, iy, pic%())
'* my failed attempt at redrawing a screen region so only regions of screen have to be redrawn
x1 = SetToMinMax(p.px - p.radius, p.radius, _WIDTH - p.radius)
y1 = SetToMinMax(p.py - p.radius, p.radius, _HEIGHT - p.radius)
x2 = SetToMinMax(p.px + p.radius, x1 + p.radius, _WIDTH - p.radius)
y2 = SetToMinMax(p.py + p.radius, y1 + p.radius, _HEIGHT - p.radius)
PUT (x1, y1), pic%(ix, iy, 1), PSET
END SUB

SUB PrintLocate (row, col, what$, whatcolor, gotonextline, doinput, ret$)
LOCATE row, col
COLOR whatcolor
PRINT what$;
IF doinput THEN
    LINE INPUT ret$
END IF
IF gotonextline THEN PRINT
END SUB


SUB findCentroid (x(), y(), n, cx, cy)
x(n) = x(0)
y(n) = y(0)
ax = 0
DO
    i = ax
    IF i < n THEN
        ax = i + 1
        d = x(i) * y(ax) - x(ax) * y(i)
        cx = cx + (x(i) + x(ax)) * d
        cy = cy + (y(i) + y(ax)) * d
        a = a + d
    ELSE
        EXIT DO
    END IF
LOOP
cx = cx / (3 * a)
cy = cy / (3 * a)
END SUB

SUB saveimage (i AS LONG, filename AS STRING)
bytesperpixel& = _PIXELSIZE(i&
IF bytesperpixel& = 0 THEN PRINT "Text modes unsupported!": END
IF bytesperpixel& = 1 THEN bpp& = 8 ELSE bpp& = 24
x& = _WIDTH(i&
y& = _HEIGHT(i&
b$ = "BM????QB64????" + MKL$(40) + MKL$(x& + MKL$(y& + MKI$(1) + MKI$(bpp& + MKL$(0) + "????" + MKL$(0) + MKL$(0) + MKL$(0) + MKL$(0)
IF bytesperpixel& = 1 THEN
    FOR c& = 0 TO 255
        cv& = _PALETTECOLOR(c&, i&
        b$ = b$ + CHR$(_BLUE32(cv& + CHR$(_GREEN32(cv& + CHR$(_RED32(cv& + CHR$(0)
    NEXT
END IF
MID$(b$, 11, 4) = MKL$(LEN(b$))
lastsrc& = _SOURCE
_SOURCE i&
FOR py& = y& - 1 TO 0 STEP -1
    r$ = ""
    FOR px& = 0 TO x& - 1
        c& = POINT(px&, py&
        IF bytesperpixel& = 1 THEN r$ = r$ + CHR$(c& ELSE r$ = r$ + LEFT$(MKL$(c&, 3)
    NEXT px&
    IF (bytesperpixel& * x& AND 3 THEN r$ = r$ + SPACE$((bytesperpixel& * x& AND 3)
    d$ = d$ + r$
NEXT py&
_SOURCE lastsrc&
MID$(b$, 35, 4) = MKL$(LEN(d$))
b$ = b$ + d$
MID$(b$, 3, 4) = MKL$(LEN(b$))
IF LCASE$(RIGHT$(filename$, 4)) <> ".bmp" THEN ext$ = ".bmp"
f& = FREEFILE
OPEN filename$ + ext$ FOR OUTPUT AS #f&: CLOSE #f&
OPEN filename$ + ext$ FOR BINARY AS #f&
PUT #f&, , b$
CLOSE #f&
END SUB

Shocked
I could not for the life of me figure out where in this thread the Search found "Battleship".
Quote: '* PointDsp$ = "Holy Klingon! -- They sank our battleship (" + MID$(STR$(points&Wink, 2) + ")"

If the Battleship was called "Kitchen" then this code contains everything including the Kitchen sink!
B += x
Reply
#23
I thought Thee Second Amendment gave us the right to arm bears..

Erik.
dndbbs project:

Links to my MUD: (strictly 16-bit); AKA XP:

Dndbbs executables
http://www.filegate.net/pdn/pdnbasic/dnd50a1e.zip

Dndbbs source
http://www.filegate.net/pdn/pdnbasic/dnd50a1s.zip

Dndbbs upgrade
http://www.filegate.net/pdn/pdnbasic/dnd50a1u.zip

DNDDOOR - https://bit.ly/EriksDNDDoor DUNGEON - https://bit.ly/EriksDungeon
Interpreter - https://bit.ly/EriksSICK Hex Editor - https://bit.ly/EriksHexEditor Utilities - https://bit.ly/EriksUtils
QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: - https://bit.ly/OldQB64
Reply
#24
(04-23-2018, 09:27 AM)eoredson Wrote: I thought Thee Second Amendment gave us the right to arm bears..

Erik.

Bears have arms (when they stand up for their rights) without need of any amendments (let alone a second one!) Big Grin
B += x
Reply