'===========================================================================
' Subject: BILLIARD SIMULATOR                 Date: 08-30-00 (01:50)       
'  Author: Antoni Gual                        Code: QB, QBasic, PDS        
'  Origin: agual@eic.ictnet.es              Packet: DEMOS.ABC
'===========================================================================
DECLARE SUB GNOISE (I%)
'---------------------------------------------------------------------------'
'BILLIARD for QBASIC by Antoni Gual     agual@eic.ictnet.es                 '
' It simply tries to simulate billiard physics, not the game's rules, of    '
'   which I have no idea                                                    '
'---------------------------------------------------------------------------'
'Features:  multi screen mode. In VGA  you can use modes 7,8,9,12,13.       '
'           simulates ball spinning, so you can use effects.                '
'           A single FUNCTION mouse routine you can use in your programs    '
'---------------------------------------------------------------------------'
'Use as you want, only give me credit                                       '
' Let me know if you do any enhancement to the code!                        '
'---------------------------------------------------------------------------'
'Acknowledgements:                                                          '
'-  Theory comes from the program Le Billard Fou, by Fr‚d‚ric Neuville,     '
'     published in the French magazine Science & Vie Micro in January 1986. '
'     (It was for an Apple II..)                                            '
'-  A QB program found in Andreas Meile webpage has also inspired me,       '
'     although I can't read german at all :)                                '
'-  The short mouse routine is rewritten from a contribution to ABC by      '
'     Dan Campbell.                                                         '
'                                                                           '
'If you want to go further, and you have a solid knowledge in physics, you  '
' can study the pdf in www.playpool.com/apapp/download.htm.                 '
' (I warn you, a lot of vectorial maths)                                    '
'---------------------------------------------------------------------------'
' USE: You can play in two ways, depending of the value of the constant     '
'  BallSpin                                                                 '
' -If ballspin=0 you need only to click in the place around the cue ball    '
'   from where the cue will hit the ball. The cue will hit the center of    '
'   the ball, so no effects.(Cue ball has a cross on it).                   '
' -If ballspin=1, after the first click you must consider the cue ball as   '
'   viewed from the back. Then you must click in the place the cue must hit.'
'   This way you can give effects to the ball.A click outside the ball will '
'   be considered as a click in the center.                                 '
'---------------------------------------------------------------------------'
DECLARE FUNCTION delta! (v AS ANY)
DECLARE SUB GScreenInit ()
DECLARE SUB MoveBalls (t!)
DECLARE SUB Rebounds ()
DECLARE SUB GUserInput (canswap%)
DECLARE SUB GDrawBalls (canswap%)
DECLARE SUB initgame (canswap%)
DECLARE SUB GDrawTable (canswap%)
DECLARE FUNCTION GMouseInt% (func%, X%, y%)

TYPE vector
    X   AS SINGLE
    y   AS SINGLE
    z   AS SINGLE
END TYPE

'TYPE screentype
'    scr  AS INTEGER
'    mlin AS INTEGER
'    mcol AS INTEGER
'    mx   AS INTEGER
'    my   AS INTEGER
'    moumy AS INTEGER
'    mouxsc AS SINGLE
'    mouysc AS SINGLE
'    maxx AS INTEGER
'    maxy AS INTEGER
'    minx AS INTEGER
'    muny AS INTEGER
'    canswap AS INTEGER
'END TYPE

TYPE balltype
    posi    AS vector
    lastp   AS vector
    SPEED   AS vector
    SPin    AS vector
    rad     AS SINGLE
    mass    AS SINGLE
    mi      AS SINGLE
    clr     AS INTEGER
    moving  AS INTEGER
END TYPE

CONST false = 0, true = NOT false
'physical constants
CONST pi = 3.141592
CONST gravity = 9.81
CONST Rebound = .9                    'Rebound coeficient 0(nonelastic) to 1
CONST rollfrict = .05                 'friction when ball rolls
CONST slidefrict = .1                 'friction when ball slides
CONST cushfrict = .1
CONST dt = .05                        'time increment on each calc

'screen
CONST maxx% = 300
CONST maxy% = 220
CONST border% = 50             'border size
CONST maxxb% = maxx% + border
CONST maxyb% = maxy% + border
CONST backclr = 3              'table color
CONST scr = 12                 'screen mode 0,3,4,5,6 error, 1,2,10,11 balls not displayed
DIM canswap AS INTEGER, mousexscale, mouseyscale
                             


'other
CONST maxballs% = 3
CONST fillthem = true
CONST frames = 100             'number of calculations between two displays              
CONST DONOISE = true           'true if yoyou want to hear a noise when ball is hit
CONST ballspin = true          'true if program must take into account the spin
CONST energydisp = false       'debugging

DIM BALL(1 TO maxballs%) AS balltype


GScreenInit
'--------------------------------main loop-----------------------------------
DO      'games loop
    framecount% = 1
    initgame (canswap)
    dummy% = GMouseInt(0, 0, 0)
    'shot loop
    DO
        GUserInput (canswap)
        'loop until balls stop
        DO        ' ball movement loop
            MoveBalls (dt)
            Rebounds
            'do not display the result of every single calculation
            framecount% = framecount% - 1
            IF framecount% = 0 THEN GDrawBalls (canswap): framecount% = frames
            'check if any ball still moving
            moving% = false
            FOR I% = 1 TO maxballs%
                IF BALL(I%).moving THEN moving% = true
            NEXT
        LOOP UNTIL (NOT moving%) OR LEN(INKEY$)
        FOR I% = 1 TO maxballs%
            BALL(I%).SPEED.X = 0: BALL(I%).SPEED.y = 0: BALL(I%).SPEED.z = 0
            BALL(I%).SPin.X = 0: BALL(I%).SPin.y = 0: BALL(I%).SPin.z = 0
        NEXT
        DO: LOOP UNTIL LEN(INKEY$) = 0
    LOOP UNTIL LEN(INKEY$)
    IF canswap THEN SCREEN , , 0, 0
    LOCATE 1, 1: INPUT "Another game?", a$
LOOP UNTIL UCASE$(a$) = "N"
END

'---------------------------------DATA---------------------------------------
balls:
'ball 1
DATA 80,0,0,0,0,0,0,0,0
DATA 19.5,1,10,10
'ball 2
DATA 30,50,0,0,0,0,0,0,0
DATA 19.5,1,10,11
'ball 3
DATA -50,-30,0,0,0,0,0,0,0
DATA 19.5,1,10,12

MouseData:               '<!--- WARNING - Do not change this... ---!>
 DATA &h55,&h8b,&hec,&h56,&h57
 DATA &h8b,&h76,&h0c,&h8b,&h04
 DATA &h8b,&h76,&h0a,&h8b,&h1c
 DATA &h8b,&h76,&h08,&h8b,&h0c
 DATA &h8b,&h76,&h06,&h8b,&h14
 DATA &hcd,&h33                 : '&H33 is the interrupt number
 DATA &h8b,&h76,&h0c,&h89,&h04
 DATA &h8b,&h76,&h0a,&h89,&h1c
 DATA &h8b,&h76,&h08,&h89,&h0c
 DATA &h8b,&h76,&h06,&h89,&h14
 DATA &h5f,&h5e,&h5d
 DATA &hca,&h08,&h00
 DATA &hff

FUNCTION delta (v AS vector)
delta = SQR(v.X * v.X + v.y * v.y + v.z * v.z)
END FUNCTION

SUB GDrawBalls (canswap%)
SHARED BALL() AS balltype
'CLS
'LINE (-maxx%, -maxy%)-(maxx%, maxy%), backclr, BF

CONST inish = 3 * pi / 2
CONST endsh = 2 * pi
CONST inibr = pi / 2
CONST endbr = pi
WAIT &H3DA, 8
FOR I% = 1 TO maxballs%
    'if ball moving erase previous position
    IF BALL(I%).moving THEN
        'erase previous
        tempx% = CINT(BALL(I%).lastp.X): tempy% = CINT(BALL(I%).lastp.y)
        CIRCLE (tempx%, tempy%), BALL(I%).rad * 1.001, backclr
        PAINT (tempx%, tempy%), backclr
    END IF
NEXT
'WAIT &H3DA, 8
FOR I% = 1 TO maxballs%
    'set last pos =actual pos
    BALL(I%).lastp.X = BALL(I%).posi.X
    BALL(I%).lastp.y = BALL(I%).posi.y
    BALL(I%).lastp.z = BALL(I%).posi.z
    'display new ball position
    tempx% = CINT(BALL(I%).posi.X): tempy% = CINT(BALL(I%).posi.y)
    CIRCLE (tempx%, tempy%), BALL(I%).rad, BALL(I%).clr
    IF fillthem THEN
        PAINT (tempx%, tempy%), BALL(I%).clr
        'CIRCLE (tempx%, tempy%), ball(i%).rad * .9, 8, inish, endsh
        'bright
        CIRCLE (tempx%, tempy%), BALL(I%).rad * .9, 15, inibr, endbr
        CIRCLE (tempx%, tempy%), BALL(I%).rad * .8, 15, inibr, endbr
    END IF
NEXT
IF energydisp THEN
    FOR I% = 1 TO maxballs%
        delta1 = delta(BALL(I%).SPEED)
        energy = energy + BALL(I%).mass * delta1 * delta1 / 2
        IF ballspin THEN
            delta2 = delta(BALL(I%).SPin)
            energy = energy + BALL(I%).mi / 2 * delta2 * delta2
        END IF
    NEXT
END IF
IF energydisp THEN COLOR 15: LOCATE 28, 1: PRINT energy;
IF canswap% THEN PCOPY 1, 0
END SUB

SUB GDrawTable (canswap%)
CONST inc = maxx / 60
IF canswap% THEN SCREEN , , 1, 0
COLOR 1: CLS
LINE (-maxx%, -maxy%)-(maxx%, maxy%), backclr, BF
COLOR 0
PSET (maxx * (-1 - 1 / 7), maxy + border% / 2)
GOSUB drawhdia
PSET (maxx * (-1 - 1 / 7), -maxy - border% / 2)
GOSUB drawhdia
PSET (maxx + border / 2, maxy * (1 + 1 / 3))
GOSUB drawvdia
PSET (-maxx - border / 2, maxy * (1 + 1 / 3))
GOSUB drawvdia

GDrawBalls (canswap%)
EXIT SUB

drawhdia:
   temp = maxx * 2 / 7
   COLOR 15
   FOR I% = 0 TO 6
    PSET STEP(temp, 0)
    LINE -STEP(inc, -2 * inc)
    LINE -STEP(inc, 2 * inc)
    LINE -STEP(-inc, 2 * inc)
    LINE -STEP(-inc, -2 * inc)
   NEXT
   COLOR 0
RETURN

drawvdia:
   temp = maxy * 2 / 3
   COLOR 15
   FOR I% = 0 TO 2
    PSET STEP(0, -temp)
    LINE -STEP(-2 * inc, -inc)
    LINE -STEP(2 * inc, -inc)
    LINE -STEP(2 * inc, inc)
    LINE -STEP(-2 * inc, inc)
    
   NEXT
   COLOR 0
RETURN

END SUB

FUNCTION GMouseInt% (func%, X%, y%) STATIC
'---------------------------------------------------------------------------'
'MINIMAL QBASIC MOUSE ROUTINE BY ANTONI GUAL agual@eic.ictnet.es            '
'Rewritten from an ABC contribution by Dan Campbell                         '
'---------------------------------------------------------------------------'
'To have mouse suport you need only this single function plus               '
' the Mousedata DATA  block in the main routine                             '
'It loads automatically assembler from data when mouse is initialized       '
'Mouse Interrupt requires first call to be to Func 0 (initialize mouse)     '
' Call also Func 0 after changing screen mode!                              '
'Only 4 functions implemented:                                              '
'   Func%=0   Mouse init.  Mouseint returns 0 if mouse not present          '
'   Func%=1   Show Cursor. Returns nothing                                  '
'   Func%=2   Hide Cursor. Returns nothing.                                 '
'               (You should hide cursor before drawing to the screen)       '
'   Func%=3   Get status. Returns coords of the cursor in X% Y% and         '
'               button status in the function name                          '
'               Mouse returns always X in the range 0-639 and Y depending on'
'               screen mode:                                                '
'               Mode 0 -50 lines                            Y 0-399         '
'               Mode 0 at 25 lines, Modes 1,2,7,8,13        Y 0-199         '
'               Modes 11,12                                 Y 0-479         '
'               Modes  9,10                                 Y 0-349         '
'               You may want to rescale the mouse coords inside this funct  '
'               Mouseint AND 1 <>0 means left button pressed                '
'               Mouseint and 2 <>0 means right button pressed               '
'---------------------------------------------------------------------------'
 
 SHARED mousexscale, mouseyscale

 DIM ml%(0 TO 24)

 ax% = func%
 SELECT CASE ax%
 CASE 0:                                      'mouse init  
    IF ml%(0) = 0 THEN   'Data must be loaded
        RESTORE MouseData
        DEF SEG = VARSEG(ml%(0))
        READ bx%: ax% = 0
        WHILE bx% <> &HFF
             POKE VARPTR(ml%(0)) + ax%, bx%
             READ bx%: ax% = ax% + 1
        WEND
    END IF
    ax% = func%
    GOSUB interrupt: GMouseInt% = ax%
 CASE 1, 2:                                   'show, hide
    GOSUB interrupt
 CASE 3:                                      'get params
    GOSUB interrupt
    X% = CINT(mousexscale * cx%) - maxxb + 1  'you will need to change this
    y% = -CINT(mouseyscale * dx%) + maxyb - 1 'rescaling!!!
    GMouseInt% = bx%
 END SELECT
EXIT FUNCTION

interrupt:
 DEF SEG = VARSEG(ml%(0))
 CALL ABSOLUTE(ax%, bx%, cx%, dx%, VARPTR(ml%(0)))
RETURN

END FUNCTION

SUB GNOISE (I%)
SELECT CASE I%
CASE 1: SOUND 37, .6
CASE 2: SOUND 1300, .05
END SELECT
END SUB

SUB GScreenInit
'screen init
SHARED mousexscale, mouseyscale
IF scr < 7 OR scr = 10 OR scr = 11 THEN PRINT "SCREEN "; scr; "Not Allowed"; : END
IF GMouseInt(0, 0, 0) = 0 THEN PRINT "This program needs mouse!": END
SCREEN scr
'mouse scaling
mousexscale = 2 * maxxb / 640
SELECT CASE scr
CASE 7, 8, 13: mouseyscale = 2 * maxyb / 200
CASE 12: mouseyscale = 2 * maxyb / 480
CASE 9: mouseyscale = 2 * maxyb / 350
END SELECT
canswap = true
IF scr >= 10 THEN canswap = false
WINDOW (-maxxb%, -maxyb%)-(maxxb%, maxyb%)
CLS

END SUB

SUB GUserInput (canswap%)
    CONST bll = 1
    CONST showmou = 1
    CONST hidemou = 2
    CONST getparmou = 3
    CONST speedpar = 50
    SHARED BALL() AS balltype
    IF canswap% THEN SCREEN , , 0, 0
    
    LINE (BALL(bll).posi.X - 50, BALL(bll).posi.y)-STEP(100, 0), 0
    LINE (BALL(bll).posi.X, BALL(bll).posi.y - 50)-STEP(0, 100), 0
    
    dummy% = GMouseInt(showmou, 0, 0)
    'direction and strength
    COLOR 15: LOCATE 1, 1: PRINT "Click around ball for shot angle and strength"
    DO
        a% = GMouseInt(getparmou, x1%, y1%)
        dx! = -BALL(bll).posi.X + x1%: dy! = -BALL(bll).posi.y + y1%
        strength = SQR(dx! * dx! + dy! * dy!)
    LOOP UNTIL a%
    dxn! = dx! / strength: dyn! = dy! / strength
    BALL(bll).SPEED.X = -dx! / speedpar
    BALL(bll).SPEED.y = -dy! / speedpar
   
    'clear last press
    DO: LOOP UNTIL GMouseInt(getparmou, X%, y%) = 0
    IF ballspin = true THEN
        'point of contact
        COLOR 15: LOCATE 1, 1: PRINT SPACE$(80)
        COLOR 15: LOCATE 1, 1: PRINT "Consider ball as rear viewed and click it for contact point"
        DO
            a% = GMouseInt(getparmou, X%, y%)
            vert = (y% - BALL(bll).posi.y) / BALL(bll).rad
            horz = (X% - BALL(bll).posi.X) / BALL(bll).rad
            IF horz * horz + vert * vert > 1 THEN horz = 0: vert = 0
        LOOP UNTIL a%
        BALL(bll).SPin.X = 2.5 * dyn! * vert / BALL(bll).rad / BALL(bll).rad
        BALL(bll).SPin.y = -2.5 * dxn! * vert / BALL(bll).rad / BALL(bll).rad
        BALL(bll).SPin.z = 2.5 * d2n! * horz / BALL(bll).rad / BALL(bll).rad
    END IF
    COLOR 15: LOCATE 1, 1: PRINT SPACE$(80)
    'ok, we have all parameters we needed, we can hit the ball
    BALL(bll).moving = true
    dummy% = GMouseInt(hidemou, 0, 0)
    IF DONOISE THEN GNOISE 1
    IF canswap% THEN SCREEN , , 1, 0
    GDrawTable (canswap%)
END SUB

SUB ideas
'ok creditos
'ok sombras
'   visualizar rotaci¢n bola
'   rotaci¢n y efectos
'ok      a¤adir rotacion al dar tacada
'ok      efecto rotacion en avance
'        efecto rotacion en banda
'        efecto rotacion en choque
'ok rozamiento suelo
'   rozamiento banda
'   pendiente
'ok usuario:rat¢n
'   visualizar taco
'   dibujar bandas, ok diamantes, troneras
'ok sonido!
'   adaptar a reglamento billares
END SUB

SUB initgame (canswap%)
'init screen
SHARED BALL() AS balltype
RESTORE balls
RANDOMIZE TIMER

'init balls

FOR I% = 1 TO maxballs%
    READ BALL(I%).posi.X, BALL(I%).posi.y, BALL(I%).posi.z
    READ BALL(I%).SPEED.X, BALL(I%).SPEED.y, BALL(I%).SPEED.z
    READ BALL(I%).SPin.X, BALL(I%).SPin.y, BALL(I%).SPin.z
    READ BALL(I%).rad, BALL(I%).mass, BALL(I%).mi, BALL(I%).clr
NEXT
GDrawTable (canswap%)
END SUB

SUB MoveBalls (dt)
SHARED BALL()  AS balltype
DIM contsp AS vector, normal AS vector, slip AS vector
FOR I% = 1 TO maxballs%
    IF BALL(I%).moving THEN
        'if ball does'nt slide
        contsp.X = BALL(I%).SPEED.X: contsp.y = BALL(I%).SPEED.y
        k = BALL(I%).rad * rollfrict * .001
        IF ballspin THEN
            slip.X = -BALL(I%).SPin.y * BALL(I%).rad
            slip.y = BALL(I%).SPin.X * BALL(I%).rad
            slip.X = BALL(I%).SPEED.X - slip.X
            slip.y = BALL(I%).SPEED.y - slip.y
            delta2 = delta(slip)
            IF delta2 < .01 THEN 'ball is slipping
               k = BALL(I%).rad * rollfrict * .001
               contsp.X = slip.X: contsp.y = slip.y
            END IF
            
        END IF
        delta1 = delta(contsp)
        normal.X = -contsp.X / delta1: normal.y = -contsp.y / delta1
        
        'calculate normal opposite to movement
        'motion equations
        BALL(I%).posi.X = BALL(I%).posi.X + dt * BALL(I%).SPEED.X + k * normal.X * dt * dt
        BALL(I%).posi.y = BALL(I%).posi.y + dt * BALL(I%).SPEED.y + k * normal.y * dt * dt
       
        'friction reduces speed
        IF ABS(k * dt * normal.X) > ABS(BALL(I%).SPEED.X) THEN
            BALL(I%).SPEED.X = 0
        ELSE
            BALL(I%).SPEED.X = BALL(I%).SPEED.X + k * dt * normal.X
        END IF
        IF ABS(k * dt * normal.y) > ABS(BALL(I%).SPEED.y) THEN
            BALL(I%).SPEED.y = 0
        ELSE
            BALL(I%).SPEED.y = BALL(I%).SPEED.y + k * dt * normal.y
        END IF
        IF ballspin THEN
            'if slipping, friction changes spin
            BALL(I%).SPin.X = BALL(I%).SPin.X - 2.5 * k * dt * normal.y / BALL(I%).rad
            BALL(I%).SPin.y = BALL(I%).SPin.y + 2.5 * k * dt * normal.X / BALL(I%).rad
        END IF
        BALL(I%).moving = false
        IF ABS(BALL(I%).SPEED.X) > .00001 THEN
            BALL(I%).moving = true
        ELSEIF ABS(BALL(I%).SPEED.y) > .00001 THEN
            BALL(I%).moving = true
        END IF
    END IF
NEXT
END SUB

SUB Rebounds
SHARED BALL() AS balltype
    FOR I% = 1 TO maxballs
     'Rebound in the east side
     IF ballspin THEN effect = BALL(I%).SPin.z * BALL(I%).rad ELSE effect = 0
     IF BALL(I%).posi.X >= maxx - BALL(I%).rad THEN
        BALL(I%).SPEED.X = -(BALL(I%).SPEED.X * Rebound)
        BALL(I%).SPEED.y = (5 * BALL(I%).SPEED.y - 2 * effect) / 7
        BALL(I%).SPin.z = -BALL(I%).SPEED.y / BALL(I%).rad
        IF DONOISE THEN GNOISE 1
        'avoiding ball glued to side
        BALL(I%).posi.X = maxx - BALL(I%).rad
     END IF
     'Rebound in north side
     IF BALL(I%).posi.y >= maxy - BALL(I%).rad THEN
        BALL(I%).SPEED.y = -(BALL(I%).SPEED.y * Rebound)
        BALL(I%).SPEED.X = (5 * BALL(I%).SPEED.X - 2 * effect) / 7
        BALL(I%).SPin.z = -BALL(I%).SPEED.X / BALL(I%).rad
        IF DONOISE THEN GNOISE 1
        'avoiding ball glued to side
        BALL(I%).posi.y = maxy - BALL(I%).rad
     END IF
     'Rebound in the west side
     IF BALL(I%).posi.X <= -maxx + BALL(I%).rad THEN
        BALL(I%).SPEED.X = -(BALL(I%).SPEED.X * Rebound)
        BALL(I%).SPEED.y = (5 * BALL(I%).SPEED.y + 2 * effect) / 7
        BALL(I%).SPin.z = BALL(I%).SPEED.y / BALL(I%).rad
        IF DONOISE THEN GNOISE 1
        'avoiding ball glued to side
        BALL(I%).posi.X = -maxx + BALL(I%).rad
     END IF
     'Rebound in south side
     IF BALL(I%).posi.y <= -maxy + BALL(I%).rad THEN
        BALL(I%).SPEED.y = -(BALL(I%).SPEED.y * Rebound)
        BALL(I%).SPEED.X = (5 * BALL(I%).SPEED.X - 2 * effect) / 7
        BALL(I%).SPin.z = -BALL(I%).SPEED.X / BALL(I%).rad
        IF DONOISE THEN GNOISE 1
        'avoiding ball glued to side
        BALL(I%).posi.y = -maxy + BALL(I%).rad
     END IF

     'checking balls hitting one to another
     'each one receives a speed vector opposite to the line joining centers
     'and proportional to the masses ratio
     FOR j% = I% + 1 TO maxballs
         dx = BALL(I%).posi.X - BALL(j%).posi.X
         dy = BALL(I%).posi.y - BALL(j%).posi.y
         dxy = SQR(dx * dx + dy * dy)
         d = BALL(I%).rad + BALL(j%).rad
         IF d >= dxy THEN
             mr = BALL(I%).mass / BALL(j%).mass
             ux = dx / dxy: uy = dy / dxy
             'if a ball penetrates the other both get glued for a while
             'next two lines avoid this
             BALL(I%).posi.X = BALL(j%).posi.X + d * ux
             BALL(I%).posi.y = BALL(j%).posi.y + d * uy

             cm = ux * (BALL(I%).SPEED.X - BALL(j%).SPEED.X) + uy * (BALL(I%).SPEED.y - BALL(j%).SPEED.y)
             cmi = -Rebound * cm / mr
             cmj = Rebound * cm * mr
             BALL(I%).SPEED.X = cmi * ux + BALL(I%).SPEED.X
             BALL(I%).SPEED.y = cmi * uy + BALL(I%).SPEED.y
             BALL(j%).SPEED.X = cmj * ux + BALL(j%).SPEED.X
             BALL(j%).SPEED.y = cmj * uy + BALL(j%).SPEED.y
             BALL(I%).moving = true: BALL(j%).moving = true
             IF DONOISE THEN GNOISE 2
         END IF
     NEXT
   NEXT
END SUB