Author Topic: My first attempts at a billiards program (Read 4725 times)

OldMoses · « **on:** March 22, 2020, 01:55:58 pm »

Taking a bit of a break from my usual 3D space based themes to play with 2D collision stuff, even though I am using some procedures from that sort of stuff. I always wanted a pool table, but never really had the room or funds for it.

Some aspects of this seem to work pretty good, others....eh, not so much...

I'm trying to make this work solely upon vector algorithms, without recourse to any sort of trig functions.

Rebound from the stiking ball is not acting as I think it probably should and balls will often overlap rather than bump the adjacent ball out of the way. No pockets yet, I'm just trying to get the physics and the collision limits to work correctly.

Yeah, it's definitely a work in progress, and I'm wondering if I may have to make the collision routine recursive in the case of nearby targets.

The white line from the cue ball is the angle of attack for the cue and the red line is where the ball will go. The length of the white line will determine the force applied, which of course limits the ability to hit hard near the edge of the table, but that is something yet to be worked out.

As usual <esc> will quit.

Updated 3/25/2020

Code: QB64: [Select]

$COLOR:32
 
'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 Vec2
    x AS SINGLE
    y AS SINGLE
END TYPE
 
TYPE ball
    sunk AS _BYTE '                                             has ball been sunk true/false
    im AS _BYTE '                                               impact register
    c AS _UNSIGNED LONG '                                       ball color
    p AS Vec2 '                                                 position vector
    d AS Vec2 '                                                 direction vector
    n AS Vec2 '                                                 normalized direction vector
    s AS SINGLE '                                               speed
    r AS _BYTE '                                                rack position
END TYPE
 
DIM SHARED xtable AS INTEGER
DIM SHARED ytable AS INTEGER
DIM SHARED bsiz AS INTEGER '                                    radius of ball
DIM SHARED bsiz2 AS INTEGER '                                   ball diameter or sphere of contact
DIM SHARED bl(15) AS ball '                                     ball data
DIM SHARED bnum(15) AS LONG
DIM SHARED origin AS Vec2
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
bsiz2 = bsiz * 2
 
RANDOMIZE TIMER
RESTORE hue
FOR x = 0 TO 15
    READ bl(x).c
    IF x = 0 THEN '                                             starting positions
        bl(x).p.y = INT(ytable * .5)
        bl(x).p.x = INT(xtable * .75)
    ELSE
        'DO
 
        '    bl(x).p.y = INT((RND(1) * (ytable - (bsiz * 2))) + bsiz)
        '    bl(x).p.x = INT((RND(1) * (xtable - (bsiz * 2))) + bsiz)
        '    t = 0
        '    FOR y = 0 TO x - 1
        '        d = ((bl(x).p.x - bl(y).p.x) ^ 2 + (bl(x).p.y - bl(y).p.y) ^ 2) ^ .5
        '        IF d < bsiz * 2 THEN t = -1
        '    NEXT y
        'LOOP UNTIL NOT t
    END IF
NEXT x
 
MakeBalls
RackEmUp
 
a& = _NEWIMAGE(xtable, ytable, 32)
shot& = _NEWIMAGE(xtable, ytable, 32)
_DEST a&: SCREEN a&
DO: LOOP UNTIL _SCREENEXISTS
_SCREENMOVE 5, 5
COLOR , &HFF3AAF61
'set up the table
CLS
FOR x = 0 TO 2
    LINE (x, x)-(xtable - x, ytable - x), Black, B
    FCirc xtable * .75, ytable * .5, 5, Gray, Gray
    FCirc xtable * .75, ytable * .5, 2, White, White
NEXT x
DO
    CLS
    FOR x = 0 TO 15
        VecAdd bl(x).p, bl(x).d, 1
        VecMult bl(x).d, .99
        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
    WHILE _MOUSEINPUT: WEND
    m1 = _MOUSEBUTTON(1)
    IF m1 THEN
        bl(0).d.x = (bl(0).p.x - _MOUSEX) * 0.05
        bl(0).d.y = (bl(0).p.y - _MOUSEY) * 0.05
        'VecNorm bl(0).d: VecMult bl(0).d, 40
    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
    'LINE (bl(0).p.x, bl(0).p.y)-(-(_MOUSEX - bl(0).p.x) + bl(0).p.x, -(_MOUSEY - bl(0).p.y) + bl(0).p.y), Blue
    'd = SQR(((bl(0).p.x - _MOUSEX) * 0.05) * ((bl(0).p.x - _MOUSEX) * 0.05) + ((bl(0).p.y - _MOUSEY) * 0.05) * ((bl(0).p.y - _MOUSEY) * 0.05))
    '_PRINTSTRING (xtable + 4, ytable - 20), STR$(d), a&
    _DISPLAY
    _LIMIT 100 '100 seems good
    'SLEEP
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 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 '                                      won't collide with self so skip self check
            IF NOT bl(var).sunk THEN '                          if ball not already out of play
                dist = PythXY(bl(var).p, bl(x).p) '             calculate distance between var and x
                IF dist - bsiz2 < disp THEN '                           if ball x is within reach of magnitude
                    'check to see if there is an impact point-  Ray trace routine
                    DIM neari AS Vec2
                    DIM strike AS Vec2
                    DIM strikeorth AS Vec2
                    DIM striker AS Vec2
                    DIM strikee AS Vec2
                    DIM orthox AS Vec2
                    DIM orthoy AS Vec2
 
                    'Using a variation of the collision routine from CTVector.bas
                    'but the damn thing isn't working as envisioned...
                    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##
                    IF disabc## <= 0 THEN 'let's make this <=, since a tangent brush by would ideally not move the ball
                    ELSE
                        t## = (-B## - ((B## * B##) - 4 * A## * C##) ^ .5) / (2 * A##) 'near intersect quadratic gives percentage of displacement to contact
                        neari.x = bl(var).p.x + t## * bl(var).d.x: neari.y = bl(var).p.y + t## * bl(var).d.y 'contact point
                        'now that we have a contact point, we can proceed to deflect the displacements of var and x
                        bl(var).p = neari
                        '// get strike angle unit vector
                        strike.x = bl(x).p.x - neari.x: strike.y = bl(x).p.y - neari.y
                        '// get the two orthogonal vectors to strike
                        orthox.x = -strike.y: orthox.y = strike.x
                        orthoy.x = strike.y: orthoy.y = -strike.x
                        '// add orthogonals to impact point
                        VecAdd orthox, neari, 1: VecAdd orthoy, neari, 1
                        '// add present var displacement to ortho's
                        VecAdd orthox, bl(var).d, 1: VecAdd orthoy, bl(var).d, 1
                        '// check distances and compare, using farthest one for striker's new vector
                        vox = PythXY(orthox, bl(x).p): voy = PythXY(orthoy, bl(x).p)
                        IF vox > voy THEN
                            strikeorth.x = -strike.y: strikeorth.y = strike.x
                        ELSEIF vox = voy THEN
                            strikeorth = strike
                        ELSE
                            strikeorth.x = strike.y: strikeorth.y = -strike.x
                        END IF
                        '// normalize strike vectors
                        VecNorm strike: VecNorm strikeorth
 
 
                        striker = bl(var).d: VecNorm striker '                  get striker unit vector
                        strikee = bl(x).d: VecNorm strikee '                    get strikee unit vector
                        dot = striker.x * strike.x + striker.y * strike.y '     apply to struck balls displacement magnitude along strike
                        dotback = 1 - dot '                                     apply to striking balls displacement along orthogonal of strike
 
                        'get proportion of energy transfer and add it to existing vector of unit x
                        VecMult strike, 0.99 * dot * PythXY(origin, bl(var).d)
                        VecAdd bl(x).d, strike, 1
                        'do the same with var using balance of energy
                        VecMult strikeorth, 0.99 * dotback * PythXY(origin, bl(var).d)
                        'VecAdd bl(var).d, strikeorth, 1
                        bl(var).d = strikeorth
                        'bl(var).d.x = -bl(var).d.x: bl(var).d.y = -bl(var).d.y
                    END IF 'disabc <= 0
                END IF 'dist < disp
            END IF 'NOT bl(var).sunk
        END IF 'x <> var
    NEXT x
 
    'wall bounces
    IF bl(var).p.x < bsiz OR bl(var).p.x > xtable - bsiz THEN
        bl(var).d.x = -bl(var).d.x
        IF bl(var).p.x < bsiz THEN '                            if beyond left edge
            bl(var).p.y = bl(var).p.y - (bl(var).d.y * ((bl(var).p.x - bsiz) / bl(var).d.x))
            bl(var).p.x = bsiz
        END IF
        IF bl(var).p.x > xtable - bsiz THEN '                   if beyond right edge
            bl(var).p.y = bl(var).p.y - (bl(var).d.y * ((bl(var).p.x - xtable + bsiz) / bl(var).d.x))
            bl(var).p.x = xtable - bsiz
        END IF
    END IF
    IF bl(var).p.y < bsiz OR bl(var).p.y > ytable - bsiz THEN
        bl(var).d.y = -bl(var).d.y
        IF bl(var).p.y < bsiz THEN '                            if beyond top edge
            bl(var).p.x = bl(var).p.x - (bl(var).d.x * ((bl(var).p.y - bsiz) / bl(var).d.y))
            bl(var).p.y = bsiz
        END IF
        IF bl(var).p.y > ytable - bsiz THEN '                   if beyond bottom edge
            bl(var).p.x = bl(var).p.x - (bl(var).d.x * ((bl(var).p.y - ytable + bsiz) / bl(var).d.y))
            bl(var).p.y = ytable - bsiz
        END IF
    END IF
 
END SUB 'ColCheck
 
 
SUB ColCheckold (var AS INTEGER)
 
    DIM strike AS Vec2
    DIM strike90 AS Vec2
    DIM striker AS Vec2
    DIM strikee AS Vec2
    striker = bl(var).d: VecNorm striker
 
    FOR x = 0 TO 15
        IF x <> var THEN '                                      another ball?
            IF NOT bl(var).sunk THEN '                          is ball on table
                d = _HYPOT(bl(var).p.x - bl(x).p.x, bl(var).p.y - bl(x).p.y)
                IF d <= bsiz * 2 THEN
                    ''here's the crunchy part
 
                    'we must find the actual impact point, rather than the overlap at iteration point
                    'maybe that will fix the sticking
                    strike.x = bl(x).p.x - bl(var).p.x '        get strike angle unit vector
                    strike.y = bl(x).p.y - bl(var).p.y
                    VecNorm strike
                    'striker = bl(var).d: VecNorm striker '      get striker unit vector
                    'strikee = bl(x).d: VecNorm strikee '        get strikee unit vector
                    ''dot product the striker and strikee
                    'dot = striker.x * strikee.x + striker.y * strikee.y
                    'dotback = 1 - dot
                    'VecMult strike, dot * _HYPOT(bl(var).d.x, bl(var).d.y)
                    'VecAdd bl(x).d, strike, 1
 
                    'a temporary test
                    bl(x).d.x = strike.x * (.8 * bl(var).d.x)
                    bl(x).d.y = strike.y * (.8 * bl(var).d.y)
                    bl(var).d.x = -strike.y * (.2 * bl(var).d.y)
                    bl(var).d.y = -strike.x * (.2 * bl(var).d.x)
                END IF
            END IF
        END IF
    NEXT x
    IF bl(var).p.x < bsiz OR bl(var).p.x > xtable - bsiz THEN
        bl(var).d.x = -bl(var).d.x
        IF bl(var).p.x < bsiz THEN '                            if beyond left edge
            bl(var).p.y = bl(var).p.y - (bl(var).d.y * ((bl(var).p.x - bsiz) / bl(var).d.x))
            bl(var).p.x = bsiz
        END IF
        IF bl(var).p.x > xtable - bsiz THEN '                   if beyond right edge
            bl(var).p.y = bl(var).p.y - (bl(var).d.y * ((bl(var).p.x - xtable + bsiz) / bl(var).d.x))
            bl(var).p.x = xtable - bsiz
        END IF
    END IF
    IF bl(var).p.y < bsiz OR bl(var).p.y > ytable - bsiz THEN
        bl(var).d.y = -bl(var).d.y
        IF bl(var).p.y < bsiz THEN '                            if beyond top edge
            bl(var).p.x = bl(var).p.x - (bl(var).d.x * ((bl(var).p.y - bsiz) / bl(var).d.y))
            bl(var).p.y = bsiz
        END IF
        IF bl(var).p.y > ytable - bsiz THEN '                   if beyond bottom edge
            bl(var).p.x = bl(var).p.x - (bl(var).d.x * ((bl(var).p.y - ytable + bsiz) / bl(var).d.y))
            bl(var).p.y = ytable - bsiz
        END IF
    END IF
 
END SUB 'ColCheckold
 
 
SUB DisplayBall (var AS INTEGER)
 
 
END SUB 'DisplayBall
 
 
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
 
 
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
 
 
FUNCTION PythXY (var1 AS Vec2, var2 AS Vec2)
 
    'Use to find distance between two 2D points
    'Also calculate speed/magnitude of updated vectors
 
    PythXY = _HYPOT(ABS(var1.x - var2.x), ABS(var1.y - var2.y))
 
END FUNCTION 'PythXY
 
 
SUB RackEmUp
 
    yoff = bsiz2 + 4
    xoff = SQR((yoff / 2) * (yoff / 2) + yoff * yoff)
 
    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
    NEXT rank
 
END SUB 'RackEmUp
 
 
SUB VecAdd (var AS Vec2, var2 AS Vec2, 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
 
 
SUB VecMult (vec AS Vec2, multiplier AS SINGLE)
 
    'multiply vector by scalar value
    vec.x = vec.x * multiplier
    vec.y = vec.y * multiplier
 
END SUB 'VecMult
 
SUB VecNorm (var AS Vec2)
 
    'convert var to unit vector
    m = SQR(var.x * var.x + var.y * var.y)
    var.x = var.x / m
    var.y = var.y / m
 
END SUB 'VecNorm
 

bplus · « **Reply #1 on:** March 22, 2020, 04:55:47 pm »

Hey nice balls!

bplus · « **Reply #2 on:** March 25, 2020, 01:24:51 am »

Need a table? The ball action is worse than I remember! I must of been modifying it... anyway the table is kind of nice :)

Code: QB64: [Select]

_TITLE "Pool v1 by bplus 2018-04-07"
'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
'translated from:
' pool table.bas SmallBASIC 0.12.9 (B+=MGA) 2017-09-06
 
CONST xmax = 1280
CONST ymax = 740
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 80, 0
 
RANDOMIZE TIMER
'balls
CONST topBall = 15
CONST brad = 11 'ball radius 2.25"
CONST bdia = 22
'table
CONST tl = 978 'table 100" for 9 foot table, adjust down for pixel ball radius
CONST txo = (xmax - tl) * .5 'table x offset from left side of screen
CONST tw = 489 'table 50" for 9 foot table, adjust down for pixel ball radius
CONST tyo = (ymax - tw) \ 2 ' same border for 1280 wide screen
CONST mt = txo + .5 * tl
'pockets
CONST pw = 40 'pockey width less than 2 balls across
CONST pr = 20
'rails
CONST lr = txo
CONST rr = txo + tl
CONST tr = tyo
CONST br = tyo + tw
 
'color
CONST bumper&& = _RGB32(0, 168, 70)
CONST felt&& = _RGB32(0, 128, 50)
'DIM SHARED mx, my
DIM SHARED x(topBall), y(topBall), a(topBall), dx(topBall), dy(topBall), s(topBall), c(topBall), z(topBall)
DIM SHARED rack(topBall, 2)
 
drawTable
eightBallRack
BallInHand
 
WHILE 1
    IF x(0) = -1000 THEN BallInHand
    getCueBallAngle
    'get speed of cue  how much do I need?
 
    notDone = 1
    WHILE notDone
        drawTable
        CP 1, "Watch Ball Action!"
        notDone = 0
        FOR i = 0 TO topBall
            a(i) = _ATAN2(dy(i), dx(i))
            IF s(i) <> 0 THEN s(i) = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
            imoved = 0
            FOR j = i + 1 TO topBall
 
                ' The following is STATIC's adjustment of ball positions if overlapping
                ' before calcultion of new positions from collision
                ' Displacement vector and its magnitude.  Thanks STxAxTIC !
                nx = x(j) - x(i)
                ny = y(j) - y(i)
                nm = SQR(nx ^ 2 + ny ^ 2)
                IF nm < 1 + bdia THEN
                    imoved = 1
                    nx = nx / nm
                    ny = ny / nm
 
                    ' Regardless of momentum exchange, separate the balls along the lone connecting them.
                    DO WHILE nm < 1 + bdia
                        flub = .001 '* RND
 
                        x(j) = x(j) + flub * nx
                        y(j) = y(j) + flub * ny
 
                        x(i) = x(i) - flub * nx
                        y(i) = y(i) - flub * ny
 
                        nx = x(j) - x(i)
                        ny = y(j) - y(i)
                        nm = SQR(nx ^ 2 + ny ^ 2)
                        nx = nx / nm
                        ny = ny / nm
                    LOOP
 
 
                    imoved = 1
                    a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                    a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
                    'update new dx, dy for i and j balls
                    s(j) = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
                    power = .7 * (s(i) + s(j)) / 2
                    dx(i) = power * COS(a(i))
                    dy(i) = power * SIN(a(i))
                    dx(j) = power * COS(a(j))
                    dy(j) = power * SIN(a(j))
                    x(i) = x(i) + dx(i)
                    y(i) = y(i) + dy(i)
                    x(j) = x(j) + dx(j)
                    y(j) = y(j) + dy(j)
 
 
                END IF
            NEXT
            IF imoved = 0 THEN
                x(i) = x(i) + dx(i)
                y(i) = y(i) + dy(i)
            END IF
 
            IF x(i) < lr + brad THEN
                IF y(i) > tr + 17 AND y(i) < br - 17 THEN
                    a(i) = _PI - a(i): x(i) = lr + brad
                ELSE
                    x(i) = -1000 'pocketed
                END IF
            END IF
 
            IF x(i) > rr - brad THEN
                IF y(i) > tr + 17 AND y(i) < br - 17 THEN
                    a(i) = _PI - a(i): x(i) = rr - brad
                ELSE
                    x(i) = -1000 'pocket
                END IF
            END IF
 
            IF y(i) < tr + brad THEN
                IF (x(i) > lr + 17 AND x(i) < mt - 9) OR (x(i) > mt + 9 AND x(i) < rr - 17) THEN
                    a(i) = -a(i): y(i) = tr + brad
                ELSE
                    x(i) = -1000 ' pocket
                END IF
            END IF
 
            IF y(i) > br - brad THEN
                IF (x(i) > lr + 17 AND x(i) < mt - 9) OR (x(i) > mt + 9 AND x(i) < rr - 17) THEN
                    a(i) = -a(i): y(i) = br - brad
                ELSE
                    x(i) = -1000 ' pocket
                END IF
            END IF
 
            IF a(i) > _PI * 2 THEN a(i) = a(i) - _PI * 2
            IF a(i) < 0 THEN a(i) = a(i) + _PI * 2
 
            IF s(i) > 0 THEN s(i) = s(i) - .01
            IF s(i) < .05 THEN s(i) = 0
 
            'update ball position
            IF x(i) <> -1000 THEN
                IF s(i) <> 0 THEN notDone = 1
                x(i) = x(i) + COS(a(i)) * s(i)
                y(i) = y(i) + SIN(a(i)) * s(i)
                drawball i
            END IF
 
            c(i) = 0
        NEXT
        _DISPLAY
        _LIMIT 20
    WEND
    'check status of balls pocketed...
WEND
END
 
FUNCTION rand% (lo%, hi%)
    rand% = INT(RND * (hi% - lo% + 1)) + lo%
END FUNCTION
 
 
SUB getCueBallAngle 'get speed too
    'local i, mx, my
 
    m = _MOUSEINPUT
    mb = _MOUSEBUTTON(1)
    lastmx = _MOUSEX
    lastmy = _MOUSEY
 
 
    WHILE mb = 0
        m = _MOUSEINPUT
        mb = _MOUSEBUTTON(1)
        mx = _MOUSEX
        my = _MOUSEY
        IF mx <> lastmx OR my <> lastmy THEN
            IF mx > txo + brad AND mx < txo + tl - brad THEN
                lastmx = mx
                IF my > tyo + brad AND my < tyo + tw - brad THEN
                    lastmy = my
                    drawTable
                    FOR i = 0 TO topBall
                        drawball i
                    NEXT
                    CP 1, "Click for cue ball angle"
                    COLOR _RGB32(255, 255, 255)
                    LINE (x(0), y(0))-(mx, my)
                END IF
            END IF
        END IF
        _DISPLAY
        _LIMIT 100
    WEND
    s(0) = SQR((my - y(0)) ^ 2 + (mx - x(0)) ^ 2) / 10
    IF s(0) < 5 THEN s(0) = 10
    IF s(0) > 10 THEN s(0) = 20
    a(0) = _ATAN2(my - y(0), mx - x(0))
    dx(0) = s(0) * COS(a(0))
    dy(0) = s(0) * SIN(a(0))
    IF a(0) < 0 THEN a(0) = a(0) + 2 * _PI
    drawTable
    FOR i = 0 TO topBall
        drawball i
    NEXT
    CP 1, "Cue Ball angle is " + STR$(a(0)) + ", speed is " + STR$(s(0))
    _DISPLAY
END SUB
 
SUB BallInHand
    CP 1, "Ball 'in hand' behind table head line, click place for cue ball."
    m = _MOUSEINPUT
    mb = _MOUSEBUTTON(1)
    mx = _MOUSEX
    my = _MOUSEY
 
    WHILE mb = 0 'wait for click
        m = _MOUSEINPUT
        mb = _MOUSEBUTTON(1)
        mmx = _MOUSEX
        mmy = _MOUSEY
 
 
        IF mmx > txo + .75 * tl AND mmx < txo + tl - brad THEN mx = mmx
        IF mmy > tyo + brad AND mmy < tyo + tw - brad THEN my = mmy
        _LIMIT 100
    WEND
    x(0) = mx: y(0) = my
    drawball 0
    _DISPLAY
END SUB
 
SUB eightBallRack
    'local xoff, yoff, spacer, b, xx, yy, i, rndB, saveI, shuff
    xoff = txo + .25 * tl
    yoff = tyo + .5 * tw
    spacer = bdia
    b = 1
    FOR xx = 0 TO 4
        FOR yy = 0 TO xx
            x(b) = xoff - spacer * (xx)
            y(b) = yoff - .5 * spacer * xx + yy * spacer
            rack(b, 0) = x(b): rack(b, 1) = y(b)
            b = b + 1
        NEXT
    NEXT
    DIM shuff(topBall)
    FOR i = 1 TO topBall
        shuff(i) = i
    NEXT
    FOR i = topBall TO 2 STEP -1
        rndB = rand(1, i)
        SWAP shuff(i), shuff(rndB)
    NEXT
    FOR i = 1 TO topBall
        IF shuff(i) = 8 THEN saveI = i
        z(i) = RND * 2 * _PI
    NEXT
    SWAP shuff(saveI), shuff(5)
    FOR i = 1 TO topBall
        x(shuff(i)) = rack(i, 0)
        y(shuff(i)) = rack(i, 1)
        drawball shuff(i)
    NEXT
    _DISPLAY
END SUB
 
SUB drawTable
    'local i
    COLOR &HFF000088, _RGB32(0, 94, 62)
    CLS
    FOR i = 60 TO 1 STEP -1
        COLOR _RGB32(90 - .9 * i, 45 - .7 * i, 30 - .5 * i)
        rect txo - i, tyo - i, rr + i, br + i, 1
    NEXT
    COLOR bumper&&
    rect txo - brad, tyo - brad, rr + brad, br + brad, 1
    COLOR felt&&
    rect txo, tyo, rr, br, 1
    tLine txo + .25 * tl, tyo + .5 * tw, txo - bdia, tyo - bdia, pw
    tLine txo + .25 * tl, tyo + .5 * tw, txo - bdia, tyo + tw + bdia, pw
    tLine txo + tw, tyo - bdia, txo + tw, tyo + tw + bdia, pw
    tLine txo + .75 * tl, tyo + .5 * tw, txo + tl + bdia, tyo - bdia, pw
    tLine txo + .75 * tl, tyo + .5 * tw, txo + tl + bdia, tyo + tw + bdia, pw
    COLOR 0
    fcirc txo - bdia, tyo - bdia, pr
    fcirc txo + tw, tyo - bdia, pr
    fcirc txo + tl + bdia, tyo - bdia, pr
    fcirc txo - bdia, tyo + tw + bdia, pr
    fcirc txo + tw, tyo + tw + bdia, pr
    fcirc txo + tl + bdia, tyo + tw + bdia, pr
    _DISPLAY
END SUB
 
SUB tLine (x1, y1, x2, y2, rThick)
    'x1, y1 is one endpoint of line
    'x2, y2 is the other endpoint of the line
    'rThick is the radius of the tiny circles that will be drawn
    '   from one end point to the other to create the thick line
    'Yes, the line will then extend beyond the endpoints with circular ends.
 
    'local length, stepx, stepy, dx, dy, i
    rThick = INT(rThick / 2): stepx = x2 - x1: stepy = y2 - y1
    length = INT((stepx ^ 2 + stepy ^ 2) ^ .5)
    IF length THEN
        dx = stepx / length: dy = stepy / length
        FOR i = 0 TO length
            fcirc x1 + dx * i, y1 + dy * i, rThick
        NEXT
    ELSE
        fcirc x1, y1, rThick
    END IF
END SUB
 
SUB drawball (idx)
    'local r, g, b, i, ra, x1, y1
    SELECT CASE idx
        CASE 1, 9: r = 125: g = 125: b = 0
        CASE 2, 10: r = 0: g = 0: b = 145
        CASE 3, 11: r = 145: g = 0: b = 0
        CASE 4, 12: r = 0: g = 0: b = 50
        CASE 5, 13: r = 145: g = 75: b = 0
        CASE 6, 14: r = 0: g = 45: b = 0
        CASE 7, 15: r = 100: g = 0: b = 80
        CASE 8: r = 10: g = 10: b = 10
    END SELECT
    FOR i = brad TO 1 STEP -1
        IF idx = 0 OR idx > 8 THEN
            COLOR _RGB32(255 - i * 8, 255 - i * 8, 255 - i * 8)
        ELSE
            COLOR _RGB32(r, g, b)
        END IF
        fcirc x(idx), y(idx), i
        IF r THEN r = r + 7
        IF g THEN g = g + 7
        IF b THEN b = b + 7
    NEXT
    IF idx > 8 THEN
        COLOR _RGB32(r, g, b)
        ra = z(idx)
        x1 = x(idx) + 9 * COS(ra): y1 = y(idx) + 9 * SIN(ra)
        tLine x(idx), y(idx), x1, y1, 6
        x1 = x(idx) + 9 * COS(ra - _PI): y1 = y(idx) + 9 * SIN(ra - _PI)
        tLine x(idx), y(idx), x1, y1, 6
    END IF
END SUB
 
SUB CP (lineNumber, mess$)
    ttw = 8: tth = 16
    COLOR _RGB32(0, 0, 0)
    rect 0, th * lineNumber, xmax, th * lineNumber + th, 1
    COLOR _RGB32(255, 255, 255), _RGB32(0, 94, 62)
    _PRINTSTRING ((xmax - ttw * LEN(mess$)) / 2, tth * lineNumber), mess$
    _DISPLAY
END SUB
 
SUB rect (x1, y1, x2, y2, fill)
    IF fill THEN LINE (x1, y1)-(x2, y2), , BF ELSE LINE (x1, y1)-(x2, y2), , B
END SUB
 
'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
    DIM subRadius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG
 
    subRadius = ABS(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0
 
    IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
 
    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    LINE (CX - X, CY)-(CX + X, CY), , BF
 
    WHILE X > Y
        RadiusError = RadiusError + Y * 2 + 1
        IF RadiusError >= 0 THEN
            IF X <> Y + 1 THEN
                LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            END IF
            X = X - 1
            RadiusError = RadiusError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    WEND
END SUB
 
 

Ashish · « **Reply #3 on:** March 25, 2020, 05:44:25 am »

Amazing! Nice graphics

Dimster · « **Reply #4 on:** March 25, 2020, 10:02:13 am »

OldMoses - keep going. Great action on those balls. Seem to get an excellent angle to the bounce off the cushions. In your plans for a "finished" product, would those aiming lines still be visible? I'm thinking the white line would become the cue stick but not sure is the orange(yellow?) line will still be used?

bplus - you do game tables so well. I love the event horizon action on the side pockets of those balls travelling along the rails. I always believed, if I hit ball soft enough to hug the rail, the gravity well of the side pocket should draw that ball into the hole as it passed the opening. Was always my Achilles heal in poke pool.

bplus · « **Reply #5 on:** March 25, 2020, 12:11:43 pm »

Quote

bplus - you do game tables so well. I love the event horizon action on the side pockets of those balls travelling along the rails. I always believed, if I hit ball soft enough to hug the rail, the gravity well of the side pocket should draw that ball into the hole as it passed the opening. Was always my Achilles heal in poke pool.

Ah, one of those flaws that become an asset? Actually they aren't supposed to fall in if they don't cross the rectangle that bumpers make. And I thought I put angles on bumpers at side pockets.

What is really blowing my mind is how slow this is running. I know I was redrawing everything and that bogs things down considerable. But back before version 1.3, Walter's or QB64 v1.2, oh I noted the version last developer model before v1.2 came out, it did run balls faster, really! I would have dropped this code ages ago if it ran as fast as it runs now in 1.4 ??? And the cue ball is acting oddly... shooting itself off unprovoked? like we are back to having to clear mouse clicks. eh!

Well the table ain't bad I can fix side pockets and now think where there is bumper the balls would be stopped from going outside a rectangle boundary farther into holes. Hey Circle Intersect Line Segment function call!

Maybe OLdMoses wants to build his own table? or call in Brunswick ;-))

OldMoses · « **Reply #6 on:** March 25, 2020, 09:53:58 pm »

Quote from: Dimster on March 25, 2020, 10:02:13 am

OldMoses - keep going. Great action on those balls. Seem to get an excellent angle to the bounce off the cushions. In your plans for a "finished" product, would those aiming lines still be visible? I'm thinking the white line would become the cue stick but not sure is the orange(yellow?) line will still be used?

I am figuring on a cue stick graphic, and the target line will probably be gone after I get the balls to behave correctly.

I do need to work in a proper table graphic, but I figured I need to get the ball action working right first. I'm a total neophyte to this sort of graphics game.

I put the balls in a starting "rack", but I'm not impressed by the break action and the balls will flip places sometimes when crowded along the edge or clustered together.

In studying the dynamics of ball impact, I had to correct the rebound characteristics of the "striking" ball relative to the struck one. That took some head scratching, but it seems to be working better. I posted the improvements to the OP code.

OldMoses · « **Reply #7 on:** March 25, 2020, 10:06:40 pm »

One interesting bug with this one is the tendency for the program to crash with no errors or warnings. It just stops. Kinda hard to have an idea why without any sort of feedback. I notice that it will do so often when one ball gets stuck behind another along the bumper.

bplus · « **Reply #8 on:** March 25, 2020, 10:17:06 pm »

Hi OldMoses,

Ball action on 1-on-1 shots pretty good, I am running out of room for drawing cue ball back when it is at the edge of the screen like playing pool in a closet.

Shut downs might be division by zero or nan's a result that is infinity. STx code fix for overlapping balls, see Dropping Balls in Samples.

OldMoses · « **Reply #9 on:** March 25, 2020, 10:27:23 pm »

Yes the short strike near a bumper is a limitation. I've got an idea to make it so that you can press and hold the mousebutton and have a force indicator build up, then release of the button will shoot the ball at the force built at the moment of release.

Thanks for the heads up to the Dropping Balls, I'll check that one out.

News:

Author Topic: My first attempts at a billiards program (Read 4725 times)

OldMoses

My first attempts at a billiards program

bplus

Re: My first attempts at a billiards program

bplus

Re: My first attempts at a billiards program

Ashish

Re: My first attempts at a billiards program

Dimster

Re: My first attempts at a billiards program

bplus

Re: My first attempts at a billiards program

OldMoses

Re: My first attempts at a billiards program

OldMoses

Re: My first attempts at a billiards program

bplus

Re: My first attempts at a billiards program

OldMoses

Re: My first attempts at a billiards program