OldMoses' Ark of the Codenant - Printable Version

Code: (Select All)
$COLOR:32

$CONSOLE

'ball colors 1 yellow 2 blue 3 red 4 purple 5 orange 6 green 7 maroon 8 black

'9 yellow/s 10 blue/s 11 red/s 12 purple/s 13 orange/s 14 green/s 15 maroon/s



TYPE V2

    x AS SINGLE

    y AS SINGLE

END TYPE



TYPE ball

    sunk AS _BYTE '                                             has ball been sunk true/false

    c AS _UNSIGNED LONG '                                       ball color

    p AS V2 '                                                   position vector

    d AS V2 '                                                   direction vector

    n AS V2 '                                                   normalized direction vector

    s AS SINGLE '                                               speed

    r AS _BYTE '                                                rack position

END TYPE



TYPE pylon '                                                    pocket throat radii 2 per pocket

    'poc as _byte '                                              'pocket #

    p AS V2 '                                                   pylon position

    vert AS V2 '                                                bumper vertex

END TYPE





DIM SHARED xtable AS INTEGER '                                  x & y limits of screen/table

DIM SHARED ytable AS INTEGER

DIM SHARED xt5 AS INTEGER '                                     table border depth (5% of xtable)

DIM SHARED bsiz AS INTEGER '                                    radius of ball

DIM SHARED bsiz2 AS INTEGER '                                   ball diameter or sphere of contact

DIM SHARED psiz AS INTEGER '                                    pocket radius

DIM SHARED bl(15) AS ball '                                     ball data

DIM SHARED pl(12) AS pylon '                                    pocket throat bumpers

DIM SHARED bnum(15) AS LONG '                                   ball image handles

DIM SHARED tbl AS LONG '                                        table image handle

DIM SHARED origin AS V2 '                                       zero vector

origin.x = 0: origin.y = 0



'Set the table size

IF _DESKTOPWIDTH > _DESKTOPHEIGHT * 1.6 THEN

    xtable = _DESKTOPWIDTH - 100: ytable = xtable / 2

ELSE

    ytable = _DESKTOPHEIGHT - 80: xtable = ytable * 2

END IF





bsiz = INT(((xtable / 118.1102) * 2.375) / 2) '                 size balls to table

_ECHO STR$(bsiz)

bsiz2 = bsiz * 2

xt5 = xtable * .05



RANDOMIZE TIMER

RESTORE hue

FOR x = 0 TO 15

    READ bl(x).c

NEXT x



MakeTable

MakeBalls

RackEmUp

bl(0).p.y = INT(ytable * .5) '                                  position the cue

bl(0).p.x = INT(xtable * .75)



a& = _NEWIMAGE(xtable, ytable, 32)

_DEST a&: SCREEN a&

DO: LOOP UNTIL _SCREENEXISTS

_SCREENMOVE 5, 5



COLOR , &HFF007632

CLS



DO

    CLS

    _PUTIMAGE , tbl, a&



    FOR x = 0 TO 15

        IF bl(x).sunk THEN

            IF x = 0 THEN

                'scratch

                bl(0).p.y = INT(ytable * .5) '                  position the cue

                bl(0).p.x = INT(xtable * .75)

            ELSE

                _CONTINUE

            END IF

        END IF

        VecAdd bl(x).p, bl(x).d, 1

        VecMult bl(x).d, .99

        IF PyT(origin, bl(x).d) < .05 THEN bl(x).d = origin

        ColCheck x

        _PUTIMAGE (INT(bl(x).p.x) - CINT(_WIDTH(bnum(x)) / 2), INT(bl(x).p.y) - CINT(_HEIGHT(bnum(x)) / 2)), bnum(x), a&

    NEXT x



    ms = MBS%

    IF ms AND 1 THEN

        IF (origin.x = bl(0).d.x) AND (origin.y = bl(0).d.y) THEN

            bl(0).d.x = bl(0).p.x - _MOUSEX '                   get the cue strike vector

            bl(0).d.y = bl(0).p.y - _MOUSEY

            VecNorm bl(0).d '                                   shrink it

            VecMult bl(0).d, su '                               grow it

            DO UNTIL NOT _MOUSEBUTTON(1) '                      prevents cue thrusting,

                WHILE _MOUSEINPUT: WEND '                       i.e. constant acceleration across table

            LOOP '                                              while holding down mouse button

            su = 0 '                                            reset strike units

        END IF

    END IF

    IF ms AND 2 THEN '                                          if mouse right button reset the rack

        BallStop '                                              all displacements to = origin

        bl(0).p.y = INT(ytable * .5)

        bl(0).p.x = INT(xtable * .75)

        RackEmUp

    END IF

    IF ms AND 4 THEN '                                          if mouse center button, set full strike

        IF su = 35 THEN su = 0

        IF su = 0 THEN su = 35

    END IF

    IF ms AND 512 THEN '                                        roll mousewheel back, accelerate away from mouse cursor

        su = Limit%(35, su + 1) '                               like pulling back a pinball spring

    END IF

    IF ms AND 1024 THEN '                                       roll mousewheel frw'd, accelerate towards mouse cursor

        su = su + 1 * (su > -35) '                              helpful in aiming from table edge

    END IF



    'LINE (_MOUSEX, _MOUSEY)-(CINT(bl(0).p.x), CINT(bl(0).p.y))

    ''slope of target line

    'pathx = CINT(bl(0).p.x) - _MOUSEX: pathy = CINT(bl(0).p.y) - _MOUSEY

    'LINE (bl(0).p.x, bl(0).p.y)-(pathx * 1000, pathy * 1000), Blue

    IF (bl(0).d.x = 0) AND (bl(0).d.y = 0) THEN

        LINE (_MOUSEX, _MOUSEY)-(CINT(bl(0).p.x), CINT(bl(0).p.y))

        'slope of target line

        pathx = CINT(bl(0).p.x) - _MOUSEX: pathy = CINT(bl(0).p.y) - _MOUSEY

        LINE (bl(0).p.x, bl(0).p.y)-(pathx * 1000, pathy * 1000), Blue



        _PRINTSTRING (bl(0).p.x - 8, bl(0).p.y - 8), STR$(su)

    END IF

    _DISPLAY

    _LIMIT 100

LOOP UNTIL _KEYDOWN(27)



END



'                                                               DATA SECTION

hue:

DATA 4294967295,4294967040,4278190335,4294901760,4286578816,4294944000,4278222848,4286578688

DATA 4278190080,4294967040,4278190335,4294901760,4286578816,4294944000,4278222848,4286578688



start:

DATA 1,2,15,14,8,3,4,6,11,13,12,7,9,10,5,0



SUB B2BCollision (ball1 AS ball, ball2 AS ball)



    DIM AS V2 un, ut, ncomp1, ncomp2, tcomp1, tcomp2

    un = ball2.p: VecAdd un, ball1.p, -1: VecNorm un '          establish unit normal

    ut.x = -un.y: ut.y = un.x '                                 establish unit tangent

    bnci1 = VecDot(un, ball1.d) '                               ball 1 normal component of input velocity

    bnci2 = VecDot(un, ball2.d) '                               ball 2 normal component of input velocity

    btci1 = VecDot(ut, ball1.d) '                               ball 1 tangent component of input velocity

    btci2 = VecDot(ut, ball2.d) '                               ball 2 tangent component of input velocity



    bncx1 = bnci2 '                                             compute normal component of ball 1 exit velocity

    bncx2 = bnci1 '                                             compute normal component of ball 2 exit velocity



    ncomp1 = un: VecMult ncomp1, bncx1 '                        unit normal exit vector x normal component of exit vector ball1

    tcomp1 = ut: VecMult tcomp1, btci1 '                        unit tangent exit vector x tangent component of exit vector

    ncomp2 = un: VecMult ncomp2, bncx2 '                        same for ball2, unit normal...

    tcomp2 = ut: VecMult tcomp2, btci2 '                        same for ball2, unit tangent...



    ball1.d = ncomp1: VecAdd ball1.d, tcomp1, 1 '               add normal and tangent exit vectors

    ball2.d = ncomp2: VecAdd ball2.d, tcomp2, 1 '               add normal and tangent exit vectors



    VecMult ball1.d, .95 '                                      lets take 5% of energy in entropic factors

    VecMult ball2.d, .95



END SUB 'B2BCollision





SUB BallStop



    FOR x = 0 TO 15

        bl(x).d = origin

    NEXT x



END SUB 'BallStop





SUB ColCheck (var AS INTEGER)



    'check for ball in displacement radius

    disp = SQR(bl(var).d.x * bl(var).d.x + bl(var).d.y * bl(var).d.y) 'vector magnitude for this iteration

    FOR x = 0 TO 15 '

        IF x = var THEN _CONTINUE

        dist = PyT(bl(var).p, bl(x).p) '                calculate distance between var and x

        IF dist < bsiz2 THEN '                          are they closer than two radii, i.e. stuck together

            DIM AS V2 un

            un = bl(var).p: VecAdd un, bl(x).p, -1 '    get a normal vector between them

            VecNorm un '                                shrink it to a unit vector

            VecMult un, (bsiz2 - dist) '                grow it by the amount they intersect

            VecAdd bl(var).p, un, 1 '                   add it to the position

            'but what if a ball penetrates past the other balls center?

        END IF

        IF dist - bsiz2 < disp THEN '                   if ball x is within reach of magnitude

            dx = bl(var).p.x - bl(x).p.x

            dy = bl(var).p.y - bl(x).p.y

            A## = (bl(var).d.x * bl(var).d.x) + (bl(var).d.y * bl(var).d.y) 'displacement range

            B## = 2 * bl(var).d.x * dx + 2 * bl(var).d.y * dy

                C## = (bl(x).p.x * bl(x).p.x) + (bl(x).p.y * bl(x).p.y) + (bl(var).p.x * bl(var).p.x)_

                     + (bl(var).p.y * bl(var).p.y) + -2 * (bl(x).p.x * bl(var).p.x + bl(x).p.y * bl(var).p.y) - (bsiz2 * bsiz2)

            disabc## = (B## * B##) - 4 * A## * C##

            'disabc## = Ray_Trace##(bl(var).p, bl(var).d, bl(x).p, bsiz2)

            IF disabc## > 0 THEN '                          ray intersects ball x position

                '''still need an impact point, or balls deflect while their still out a ways

                'DIM AS ball vball, xball

                'DIM AS V2 neari

                'vball = bl(var) '                               use temporary balls for B2BCollision call

                'xball = bl(x)

                '''// near intersect quadratic returns percentage of displacement to contact point

                't## = (-B## - ((B## * B##) - 4 * A## * C##) ^ .5) / (2 * A##)

                '''// contact point- because bsiz2 is twice radius we have ball var coordinate as impact point, not

                '''// the actual surface point of impact- we may deflect the var from this point

                'neari.x = bl(var).p.x + t## * bl(var).d.x: neari.y = bl(var).p.y + t## * bl(var).d.y

                '''// now that we have a contact point, we can proceed to deflect the displacements of var and x

                '''// omitting this makes it crash readily, but we have to do something with remaining motion {1-t##} if

                '''// we retain it. We also must use that portion to move ball x

                'vball.p = neari



                B2BCollision bl(var), bl(x) 'USE THIS ALONE IN THE IF BLOCK FOR GOOD, BUT NOT MATHEMATICAL ACTION

                'B2BCollision vball, xball

                'f## = 1 - t##

                'vball.p.x = vball.p.x + f## + vball.d.x: vball.p.y = vball.p.y + f## + vball.d.y

                'bl(var) = vball

                'bl(x) = xball



            END IF '                                        end: disabc <= 0  aka ball missed

        END IF '                                            end: dist < disp test

    NEXT x



    'wall bounces - now we need to work in pocket corners which we will tentatively treat like immobile balls flanking the holes

    'LEFT/RIGHT

    IF bl(var).p.x < bsiz + xt5 OR bl(var).p.x > xtable - bsiz - xt5 THEN

        bl(var).d.x = -bl(var).d.x

        IF bl(var).p.x < bsiz + xt5 THEN '                            if beyond left edge

            bl(var).p.x = bl(var).p.x + (2 * (bsiz + xt5 - bl(var).p.x))

        END IF

        IF bl(var).p.x > xtable - bsiz - xt5 THEN '                   if beyond right edge

            bl(var).p.x = bl(var).p.x - (2 * (bl(var).p.x - (xtable - bsiz - xt5)))

        END IF

    END IF

    'TOP/BOTTOM

    IF bl(var).p.y < bsiz + xt5 OR bl(var).p.y > ytable - bsiz - xt5 THEN

        bl(var).d.y = -bl(var).d.y

        IF bl(var).p.y < bsiz + xt5 THEN '                            if beyond top edge

            bl(var).p.y = bl(var).p.y + (2 * (bsiz + xt5 - bl(var).p.y))

        END IF

        IF bl(var).p.y > ytable - bsiz - xt5 THEN '                   if beyond bottom edge

            bl(var).p.y = bl(var).p.y - (2 * (bl(var).p.y - (ytable - bsiz - xt5)))

        END IF

    END IF



END SUB 'ColCheck





SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG, C2 AS _UNSIGNED LONG)

    DIM R AS INTEGER, RError AS INTEGER '                       SMcNeill's circle fill

    DIM X AS INTEGER, Y AS INTEGER



    R = ABS(RR)

    RError = -R

    X = R

    Y = 0

    IF R = 0 THEN PSET (CX, CY), C: EXIT SUB

    LINE (CX - X, CY)-(CX + X, CY), C, BF

    WHILE X > Y

        RError = RError + Y * 2 + 1

        IF RError >= 0 THEN

            IF X <> Y + 1 THEN

                LINE (CX - Y, CY - X)-(CX + Y, CY - X), C2, BF 'these two need white here for 9-15 balls

                LINE (CX - Y, CY + X)-(CX + Y, CY + X), C2, BF

            END IF

            X = X - 1

            RError = RError - X * 2

        END IF

        Y = Y + 1

        LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF

        LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF

    WEND

END SUB 'FCirc





FUNCTION Limit% (lim AS INTEGER, var AS INTEGER)



    Limit% = lim - ((var - lim) * (var < lim + 1))



END FUNCTION 'Limit%





SUB MakeBalls



    FOR x = 0 TO 15

        'make ball images here

        bnum(x) = _NEWIMAGE(bsiz * 2 + 4, bsiz * 2 + 4, 32)

        _DEST bnum(x)

        IF x = 0 THEN '                                         Cue ball

            FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz, bl(x).c, bl(x).c

            CIRCLE (_WIDTH(bnum(x)) / 2, _HEIGHT(bnum(x)) / 2), bsiz + 1, Black

        ELSE

            'Solids or stripes

            IF x <= 8 THEN

                FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz, bl(x).c, bl(x).c ' solid

            ELSE

                FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz, bl(x).c, White '   stripe

            END IF

            FCirc INT(_WIDTH(bnum(x)) / 2), INT(_HEIGHT(bnum(x)) / 2), bsiz - 5, White, White 'number circle

            CIRCLE (_WIDTH(bnum(x)) / 2, _HEIGHT(bnum(x)) / 2), bsiz + 1, Black

            n$ = _TRIM$(STR$(x))

            t& = _NEWIMAGE(16, 16, 32)

            _DEST t&

            COLOR Black

            _PRINTMODE _KEEPBACKGROUND

            IF LEN(n$) > 1 THEN a = 0 ELSE a = 4

            _PRINTSTRING (a, 0), n$, t&

            _DEST bnum(x)

            _PUTIMAGE (8, 8)-(_WIDTH(bnum(x)) - 8, _HEIGHT(bnum(x)) - 8), t&, bnum(x)

            _FREEIMAGE t&

        END IF

    NEXT x



END SUB 'MakeBalls





SUB MakeTable



    tbl = _NEWIMAGE(xtable, ytable, 32)

    _DEST tbl

    COLOR , &HFF007632

    CLS

    FOR x = 0 TO 2

        LINE (x, x)-(xtable - x, ytable - x), Black, B

    NEXT x

    FCirc xtable * .75, ytable * .5, 5, Gray, Gray

    FCirc xtable * .75, ytable * .5, 2, White, White

    LINE (xt5, xt5)-(xtable - xt5, ytable - xt5), &HFFFF0000, B , &HF0F0



END SUB 'MakeTable





FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)



    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!



END FUNCTION 'map!





FUNCTION MBS% 'Mouse Button Status  Author: Steve McNeill

    STATIC StartTimer AS _FLOAT

    STATIC ButtonDown AS INTEGER

    STATIC ClickCount AS INTEGER

    CONST ClickLimit## = 0.2 'Less than 1/4th of a second to down, up a key to count as a CLICK.

    '                          Down longer counts as a HOLD event.

    SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY

    WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.

        SELECT CASE SGN(_MOUSEWHEEL)

            CASE 1: tempMBS = tempMBS OR 512

            CASE -1: tempMBS = tempMBS OR 1024

        END SELECT

    WEND



    IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1

    IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2

    IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4



    IF StartTimer = 0 THEN

        IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)

            ButtonDown = 1: StartTimer = TIMER(0.01)

            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY

        ELSEIF _MOUSEBUTTON(2) THEN

            ButtonDown = 2: StartTimer = TIMER(0.01)

            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY

        ELSEIF _MOUSEBUTTON(3) THEN

            ButtonDown = 3: StartTimer = TIMER(0.01)

            Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY

        END IF

    ELSE

        BD = ButtonDown MOD 3

        IF BD = 0 THEN BD = 3

        IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit.  It's a click

            IF _MOUSEBUTTON(BD) = 0 THEN tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0

        ELSE

            IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended

                tempMBS = 0: ButtonDown = 0: StartTimer = 0

                Mouse_EndX = _MOUSEX: Mouse_EndY = _MOUSEY

            ELSE 'We've now started the hold event

                tempMBS = tempMBS OR 32 * 2 ^ ButtonDown

            END IF

        END IF

    END IF

    MBS% = tempMBS

END FUNCTION 'MBS%





SUB PylonPosition



    'UNDER CONSTRUCTION

    'side pocket width = bsiz * 2.28

    'corner pocket width = bsiz2 * 2 throat width



    'FOR x = 1 TO 12

    'NEXT x



END SUB 'PylonPosition





FUNCTION PyT (var1 AS V2, var2 AS V2)



    PyT = _HYPOT(ABS(var1.x - var2.x), ABS(var1.y - var2.y)) '  distances and magnitudes



END FUNCTION 'PyT





SUB RackEmUp



    yoff = bsiz2 + 4

    xoff = SQR((yoff / 2) * (yoff / 2) + yoff * yoff) - 4



    RESTORE start

    FOR rank = 1 TO 5

        FOR b = 1 TO rank

            READ k

            bl(k).p.x = (.25 * xtable) - (xoff * (rank - 1))

            bl(k).p.y = (.5 * ytable) - ((rank - 1) * (.5 * yoff)) + ((b - 1) * yoff)

    NEXT b, rank



END SUB 'RackEmUp





FUNCTION Ray_Trace## (var1 AS V2, var2 AS V2, var3 AS V2, var4 AS _INTEGER64)



    'var1= ball initial position, var2= ball displacement, var3= target ball position, var4= strike radius



    'typical syntax: result = Ray_Trace##(bl(var).p, bl(var).d, bl(x).p, bsiz2)



    dx## = var2.x: dy## = var2.y '                              displacement of ball

    A## = (dx## * dx##) + (dy## * dy##) '                       displacement magnitude squared

    B## = 2 * dx## * (var1.x - var3.x) + 2 * dy## * (var1.y - var3.y)

    C## = (var3.x * var3.x) + (var3.y * var3.y) + (var1.x * var1.x) + (var1.y * var1.y) + -2 * (var3.x * var1.x + var3.y * var1.y) - (var4 * var4)

    Ray_Trace## = (B## * B##) - 4 * A## * C## ' if disabc## < 0 then no intersection =0 tangent >0 intersects two points



END FUNCTION 'Ray_Trace##





SUB VecAdd (var AS V2, var2 AS V2, var3 AS INTEGER)



    var.x = var.x + (var2.x * var3) '                           add (or subtract) two vectors defined by unitpoint

    var.y = var.y + (var2.y * var3) '                           var= base vector, var2= vector to add



END SUB 'VecAdd





FUNCTION VecDot (var AS V2, var2 AS V2)



    VecDot = var.x * var2.x + var.y * var2.y '                  get dot product of var & var2



END FUNCTION 'VecDot





SUB VecMult (vec AS V2, multiplier AS SINGLE)



    vec.x = vec.x * multiplier '                                multiply vector by scalar value

    vec.y = vec.y * multiplier



END SUB 'VecMult



SUB VecNorm (var AS V2)



    m = SQR(var.x * var.x + var.y * var.y) '                    convert var to unit vector

    var.x = var.x / m

    var.y = var.y / m



END SUB 'VecNorm