[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Billiard Ball Simulator
I have been innundated with request for my Billiard Ball Simulator so despite
its long length I have decided to post the code. Please note its limitations.
This program is NOT a usefull simulator for Billiards, but only a medium sized
test program.
Morry Katz
katz@polya.stanford.edu
The following code is a quick hack I wrote for testing my parallelization
system on a medium sized program (larger than a toy). It is sort of a billiard
ball simulator (see comments at header of program).
CAVEAT EMPTOR:
1) I make no promises that this code is bug free. It seems to work on simple
test cases, but I have not tested it exhaustively.
2) It uses the MIT Cscheme macro package. A conversion to extend-syntax
should be simple. Also, the code could probably be converted to just use
functions, with some performance loss. (If you do either of the above,
please let me know since it seems silly for multiple people to do the same
work.
;;;
;;; BILLIARD.SCM: This file contains code for a very simple billiard ball
;;; simulator. The simulation takes place in two dimensions.
;;; The balls are really disks in that their height is not taken
;;; into account. All interactions are assumed to be
;;; frictionless so spin in irrelevant and not accounted for.
;;; (See section on limitations.)
;;;
;;; NOTES: A simulation is initiated by creating a number of balls and bumpers
;;; and and specifying a duration for the simulation. For each ball,
;;; its mass, radius, initial position, and initial velocity must be
;;; specified. For each bumper, the location of its two ends must be
;;; specified. (Bumpers are assumed to have zero width.)
;;;
;;; A sample run might be started as follows:
;;; (simulate
;;; (list (make-ball 2 1 9 5 -1 -1)
;;; (make-ball 4 2 2 5 1 -1))
;;; (list (make-bumper 0 0 0 10)
;;; (make-bumper 0 0 10 0)
;;; (make-bumper 0 10 10 10)
;;; (make-bumper 10 0 10 10))
;;; 30)
;;;
;;; It would create one billiard ball of mass 2 and radius 1 at position
;;; (9, 5) with initial velocity (-1, -1) and a second ball of mass 4
;;; and radius 2 at position (2, 5) with initial velocity (1, -1). The
;;; table would be a 10X10 square. (See diagram below)
;;;
;;; +---------------------------+
;;; | |
;;; | |
;;; | XXXX |
;;; | XXXXXXXX XX |
;;; |XXXXXX4XXXXX XXX2XX|
;;; | XXXXXXXX /XX |
;;; | XXXX \ |
;;; | |
;;; | |
;;; +---------------------------+
;;;
;;; LIMITATIONS: This simulator does not handle 3 body problems correctly. If
;;; 3 objects interact at one time, only the interactions of 2 of
;;; the bodies will be accounted for. This can lead to strange
;;; effects like balls tunneling through walls and other balls.
;;; It is also possible to get balls bouncing inside of each
;;; other in this way.
;;;
;;MAKE-QUEUE-RECORD returns a queue record with the given next, previous, and
;;value values
;;NEXT = The next record pointer
;;PREV = The previous record pointer
;;REST = A list of values for any optional fields (this can be used for
;; creating structure inheritance)
(define-macro (make-queue-record next prev . rest)
`(vector ,next ,prev ,@rest))
;;QUEUE-RECORD-NEXT returns the next field of the given queue record
;;QUEUE-RECORD = The queue record whose next field is to be returned
(define-macro (queue-record-next queue-record)
`(vector-ref ,queue-record 0))
;;SET-QUEUE-RECORD-NEXT! sets the next field of the given queue record
;;QUEUE-RECORD = The queue record whose next field is to be set
;;VALUE = The value to which the next field is to be set
(define-macro (set-queue-record-next! queue-record value)
`(vector-set! ,queue-record 0 ,value))
;;QUEUE-RECORD-PREV returns the prev field of the given queue record
;;QUEUE-RECORD = The queue record whose prev field is to be returned
(define-macro (queue-record-prev queue-record)
`(vector-ref ,queue-record 1))
;;SET-QUEUE-RECORD-PREV! sets the prev field of the given queue record
;;QUEUE-RECORD = The queue record whose prev field is to be set
;;VALUE = The value to which the prev field is to be set
(define-macro (set-queue-record-prev! queue-record value)
`(vector-set! ,queue-record 1 ,value))
;;QUEUE-RECORD-LEN returns the length of a queue record which has no optional
;;fields
(define-macro (queue-record-len) 2)
;;QUEUE-HEAD returns a dummy record at the end of the queue with the record
;;with the smallest key.
;;QUEUE = the queue whose head record is to be returned
(define-macro (queue-head queue)
`(vector-ref ,queue 0))
;;QUEUE-TAIL returns a dummy record at the end of the queue with the record
;;with the largest key.
;;QUEUE = the queue whose tail record is to be returned
(define-macro (queue-tail queue)
`(vector-ref ,queue 1))
;;QUEUE-<? returns the less-than comparitor to be used in sorting
;;records into the queue
;;QUEUE = The queue whose comparitor is to be returned
(define-macro (queue-<? queue)
`(vector-ref ,queue 2))
;;MAKE-SORTED-QUEUE returns a queue object. A queue header is a vector which
;;contains a head pointer, a tail pointer, and a less-than comparitor.
;;QUEUE-<? = A predicate for sorting queue items
(define (make-sorted-queue queue-<?)
(let ((queue
(vector
(make-queue-record ;The queue head record has no initial
'() ;next, previous, or value values
'())
(make-queue-record ;The queue tail record has no intial
'() ;next, previous, or value values
'())
queue-<?)))
(set-queue-record-next!
(queue-head queue)
(queue-tail queue))
(set-queue-record-prev!
(queue-tail queue)
(queue-head queue))
queue))
;;MAKE-EVENT-QUEUE-RECORD returns an event queue record with the given next,
;;previous, object, and collision-time values
;;NEXT = The next record pointer
;;PREV = The previous record pointer
;;OBJECT = The simulation object associated with this record
;;COLLISION-TIME = The collision time for this object
(define-macro (make-event-queue-record next prev object collision-time)
`(make-queue-record ,next ,prev ,object ,collision-time))
;;EVENT-QUEUE-RECORD-OBJECT returns the object associated with the given record
;;QUEUE-RECORD = The queue record whose object field is to be returned
(define-macro (event-queue-record-object queue-record)
`(vector-ref ,queue-record ,(queue-record-len)))
;;EVENT-QUEUE-COLLISION-TIME returns the collision time associated with the
;;given queue record
;;QUEUE-RECORD = The queue record whose collision time field is to be returned
(define-macro (event-queue-record-collision-time queue-record)
`(vector-ref ,queue-record ,(1+ (queue-record-len))))
;;SET-EVENT-QUEUE-COLLISION-TIME! sets the collision time associated with the
;;given queue record
;;QUEUE-RECORD = The queue record whose collision time field is to be returned
;;VALUE = The value to which it is to be set
(define-macro (set-event-queue-record-collision-time! queue-record value)
`(vector-set! ,queue-record ,(1+ (queue-record-len)) ,value))
;;QUEUE-INSERT inserts the given record in the given queue based on its value
;;QUEUE = The queue into which the record is to be inserted
;;QUEUE-RECORD = The record to be inserted in the queue
(define (queue-insert queue queue-record)
(define (actual-insert insert-record next-record)
(if (or ;If the insert position has been found
(eq? next-record ;or the end on the queue has been
(queue-tail queue)) ;reached
((queue-<? queue)
insert-record
next-record))
(sequence ;Link the insert record into the queue
(set-queue-record-next! ;just prior to next-record
(queue-record-prev
next-record)
insert-record)
(set-queue-record-prev!
insert-record
(queue-record-prev
next-record))
(set-queue-record-next!
insert-record
next-record)
(set-queue-record-prev!
next-record
insert-record))
(actual-insert ;Else, continue searching for the
insert-record ;insert position
(queue-record-next
next-record))))
(actual-insert ;Search for the correct position to
queue-record ;perform the insert starting at the
(queue-record-next ;queue head and perform the insert
(queue-head queue)))) ;once this position has been found
;;QUEUE-REMOVE removes the given queue record from its queue
;;QUEUE-RECORD = The record to be removed from the queue
(define (queue-remove queue-record)
(set-queue-record-next!
(queue-record-prev
queue-record)
(queue-record-next
queue-record))
(set-queue-record-prev!
(queue-record-next
queue-record)
(queue-record-prev
queue-record)))
;;QUEUE-SMALLEST returns the queue record with the smallest key on the given
;;queue
;;QUEUE = The queue from which the smallest record is to be extracted
(define (queue-smallest queue)
(queue-record-next
(queue-head queue)))
;;CLEAR-QUEUE! clears the given queue by destructively removing all the records
;;QUEUE = The queue to be cleared
(define (clear-queue queue)
(set-queue-record-next!
(queue-head queue)
(queue-tail queue))
(set-queue-record-prev!
(queue-tail queue)
(queue-head queue)))
;;EMPTY-QUEUE? returns true if the given queue is empty
;;QUEUE = The queue to be tested for emptiness
(define (empty-queue? queue)
(eq? (queue-record-next
(queue-head queue))
(queue-tail queue)))
;;MAKE-SIMULATION-OBJECT returns a simulation object containing the given
;;fields
;;COLLISION-PROCEDURE = A function for processing information about a potential
;; collision between this object and some ball
;;REST = A list of values for any optional fields (this can be used for
;; creating structure inheritance)
(define-macro (make-simulation-object collision-procedure . rest)
`(vector ,collision-procedure ,@rest))
;;SIMULATION-OBJECT-COLLLISION-PROCEDURE returns the collision procedure for
;;the given simulation object
;;OBJECT = The object whose collision procedure is to be returned
(define-macro (simulation-object-collision-procedure object)
`(vector-ref ,object 0))
;;SIMULATION-OBJECT-LEN returns the length of a simulation object which has no
;;optional fields
(define-macro (simulation-object-len) 1)
;;ACTUAL-MAKE-BALL returns a ball object
;;BALL-NUMBER = An index into the ball vector for this ball
;;MASS = The ball's mass
;;RADIUS = The ball's radius
;;PX = The x-coordinate of the ball's initial position
;;PY = The y-coordinate of the ball's initial position
;;VX = The x-coordinate of the ball's initial velocity
;;VY = The y-coordinate of the ball's initial velocity
(define-macro (actual-make-ball ball-number mass radius px py vx vy)
`(make-simulation-object
ball-collision-procedure ;The collision procedure for a ball
,ball-number
,mass
,radius
(make-sorted-queue ;The event queue
collision-time-<?)
0 ;Time of last collision
,px ;Position of last collision
,py ; "
,vx ;Velocity following last colliosion
,vy ; "
'() ;No vector of queue records for ball's
;with smaller numbers
'() ;No vector of queue records for bumpers
'() ;No list of balls with larger numbers
'())) ;No global event queue record, yet
(define (make-ball mass radius px py vx vy)
(actual-make-ball '() mass radius px py vx vy))
;;BALL-NUMBER returns the index of the given ball
;;BALL = The ball whose index is to be returned
(define-macro (ball-number ball)
`(vector-ref ,ball ,(simulation-object-len)))
;;SET-BALL-NUMBER! set the index of the given ball to the given value
;;BALL = The ball whose index is to be set
;;VALUE = The value to which it is to be set
(define-macro (set-ball-number! ball value)
`(vector-set! ,ball ,(simulation-object-len) ,value))
;;BALL-MASS returns the mass of the given ball
;;BALL = The ball whose mass is to be returned
(define-macro (ball-mass ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 1)))
;;BALL-RADIUS returns the radius of the given ball
;;BALL = The ball whose radius is to be returned
(define-macro (ball-radius ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 2)))
;;BALL-EVENT-QUEUE returns the sort queue of collision events for the given
;;ball
;;BALL = The ball whose event is to be returned
(define-macro (ball-event-queue ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 3)))
;;BALL-COLLISION-TIME returns the time of the last collision for the given ball
;;BALL = The ball whose collision time is to be returned
(define-macro (ball-collision-time ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 4)))
;;SET-BALL-COLLISION-TIME! sets the time of the last collision for the given
;;ball
;;BALL = The ball whose collision time is to be set
;;VALUE = The value to which the ball's collision time is to be set
(define-macro (set-ball-collision-time! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 4) ,value))
;;BALL-COLLISION-X-POSITION returns the x-coordinate of the position of the
;;last collision for the given ball
;;BALL = The ball whose collision position is to be returned
(define-macro (ball-collision-x-position ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 5)))
;;SET-BALL-COLLISION-X-POSITION! sets the x-coordinate of the position of the
;;last collision for the given ball
;;BALL = The ball whose collision position is to be set
;;VALUE = The value to which the ball's collision position is to be set
(define-macro (set-ball-collision-x-position! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 5) ,value))
;;BALL-COLLISION-Y-POSITION returns the y-coordinate of the position of the
;;last collision for the given ball
;;BALL = The ball whose collision position is to be returned
(define-macro (ball-collision-y-position ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 6)))
;;SET-BALL-COLLISION-Y-POSITION! sets the y-coordinate of the position of the
;;last collision for the given ball
;;BALL = The ball whose collision position is to be set
;;VALUE = The value to which the ball's collision position is to be set
(define-macro (set-ball-collision-y-position! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 6) ,value))
;;BALL-X-VELOCITY returns the x-coordinate of the velocity of the given ball
;;following its last collision
;;BALL = The ball whose velocity is to be returned
(define-macro (ball-x-velocity ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 7)))
;;SET-BALL-X-VELOCITY! sets the x-coordinate of the velocity of the given ball
;;BALL = The ball whose velocity is to be set
;;VALUE = The value to which the ball's velocity is to be set
(define-macro (set-ball-x-velocity! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 7) ,value))
;;BALL-Y-VELOCITY returns the y-coordinate of the velocity of the given ball
;;following its last collision
;;BALL = The ball whose velocity is to be returned
(define-macro (ball-y-velocity ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 8)))
;;SET-BALL-Y-VELOCITY! sets the y-coordinate of the velocity of the given ball
;;BALL = The ball whose velocity is to be set
;;VALUE = The value to which the ball's velocity is to be set
(define-macro (set-ball-y-velocity! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 8) ,value))
;;BALL-BALL-VECTOR returns the vector of queue records for balls with smaller
;;ball numbers
;;BALL = The ball whose ball vector is to be returned
(define-macro (ball-ball-vector ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 9)))
;;SET-BALL-BALL-VECTOR! sets the vector of queue records for balls with smaller
;;ball numbers
;;BALL = The ball whose ball vector is to be set
;;VALUE = The vector to which the field is to be set
(define-macro (set-ball-ball-vector! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 9) ,value))
;;BALL-BUMPER-VECTOR returns the vector of queue records for bumpers
;;BALL = The ball whose bumper vector is to be returned
(define-macro (ball-bumper-vector ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 10)))
;;SET-BALL-BUMPER-VECTOR! sets the vector of queue records for bumpers
;;BALL = The ball whose bumper vector is to be set
;;VALUE = The vector to which the field is to be set
(define-macro (set-ball-bumper-vector! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 10) ,value))
;;BALL-BALL-LIST returns a list of balls with larger ball numbers than the
;;given ball
;;BALL = The ball whose ball list is to be returned
(define-macro (ball-ball-list ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 11)))
;;SET-BALL-BALL-LIST! sets the list of balls with larger ball numbers than the
;;given ball
;;BALL = The ball whose ball list is to be set
;;VALUE = The value to which the ball list is to be set
(define-macro (set-ball-ball-list! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 11) ,value))
;;BALL-GLOBAL-EVENT-QUEUE-RECORD returns the global event queue record for the
;;given ball
;;BALL = The ball whose global event queue record is to be returned
(define-macro (ball-global-event-queue-record ball)
`(vector-ref ,ball ,(+ (simulation-object-len) 12)))
;;SET-BALL-GLOBAL-EVENT-QUEUE-RECORD! set the global event queue record for the
;;given ball to the given value
;;BALL = The ball whose global event queue record is to be set
;;VALUE = The value to which the global event queue record field is to be set
(define-macro (set-ball-global-event-queue-record! ball value)
`(vector-set! ,ball ,(+ (simulation-object-len) 12) ,value))
;;ACTUAL-MAKE-BUMPER returns a bumper object
;;BUMPER-NUMBER = An index into the bumper vector for this bumper
;;X1 = The x-coordiante of one end of the bumper
;;Y1 = The y-coordiante of one end of the bumper
;;X2 = The x-coordiante of the other end of the bumper
;;Y2 = The y-coordiante of the other end of the bumper
(define-macro (actual-make-bumper bumper-number x1 y1 x2 y2)
`(make-simulation-object
bumper-collision-procedure ;The collision procedure for a bumper
,bumper-number
,x1 ;The bumper endpoints
,y1
,x2
,y2))
(define (make-bumper x1 y1 x2 y2)
(actual-make-bumper '() x1 y1 x2 y2))
;;BUMPER-NUMBER returns the index of the given bumper
;;BUMPER = The bumper whose index is to be returned
(define-macro (bumper-number bumper)
`(vector-ref ,bumper ,(simulation-object-len)))
;;SET-BUMPER-NUMBER! set the index of the given bumper to the given value
;;BUMPER = The bumper whose index is to be set
;;VALUE = The value to which it is to be set
(define-macro (set-bumper-number! bumper value)
`(vector-set! ,bumper ,(simulation-object-len) ,value))
;;BUMPER-X1 returns the x-coordinate of one end of the given bumber
;;BUMPER = the bumper whose x-coordinate is to be returned
(define-macro (bumper-x1 bumper)
`(vector-ref ,bumper ,(1+ (simulation-object-len))))
;;SET-BUMPER-X1! sets the x-coordinate of one end of the given bumber
;;BUMPER = the bumper whose x-coordinate is to be set
;;VALUE = The value to which the bumpers x-coordinate is to be set
(define-macro (set-bumper-x1! bumper value)
`(vector-set! ,bumper ,(1+ (simulation-object-len)) ,value))
;;BUMPER-Y1 returns the y-coordinate of one end of the given bumber
;;BUMPER = the bumper whose y-coordinate is to be returned
(define-macro (bumper-y1 bumper)
`(vector-ref ,bumper ,(+ (simulation-object-len) 2)))
;;SET-BUMPER-Y1! sets the y-coordinate of one end of the given bumber
;;BUMPER = the bumper whose y-coordinate is to be set
;;VALUE = The value to which the bumpers y-coordinate is to be set
(define-macro (set-bumper-y1! bumper value)
`(vector-set! ,bumper ,(+ (simulation-object-len) 2) ,value))
;;BUMPER-X2 returns the x-coordinate of the other end of the given bumber
;;BUMPER = the bumper whose x-coordinate is to be returned
(define-macro (bumper-x2 bumper)
`(vector-ref ,bumper ,(+ (simulation-object-len) 3)))
;;SET-BUMPER-X2! sets the x-coordinate of the other end of the given bumber
;;BUMPER = the bumper whose x-coordinate is to be set
;;VALUE = The value to which the bumpers x-coordinate is to be set
(define-macro (set-bumper-x2! bumper value)
`(vector-set! ,bumper ,(+ (simulation-object-len) 3) ,value))
;;BUMPER-Y2 returns the y-coordinate of the other end of the given bumber
;;BUMPER = the bumper whose y-coordinate is to be returned
(define-macro (bumper-y2 bumper)
`(vector-ref ,bumper ,(+ (simulation-object-len) 4)))
;;SET-BUMPER-Y2! sets the y-coordinate of the other end of the given bumber
;;BUMPER = the bumper whose y-coordinate is to be set
;;VALUE = The value to which the bumpers y-coordinate is to be set
(define-macro (set-bumper-y2! bumper value)
`(vector-set! ,bumper ,(+ (simulation-object-len) 4) ,value))
;;COLLISION-TIME-<? is a predicate which returns true if the first event queueu
;;record represents a collision that will take place at an earlier time than
;;the one for the second event queue record
;;EVENT-QUEUE-RECORD1 = The first event queue record
;;EVENT-QUEUE-RECORD2 = The second event queue record
(define (collision-time-<? event-queue-record1 event-queue-record2)
(time-<?
(event-queue-record-collision-time
event-queue-record1)
(event-queue-record-collision-time
event-queue-record2)))
;;TIME-<? is a predicate which returns true if the first time is smaller than
;;the second. '() represents a time infinitly large.
(define (time-<? time1 time2)
(if (null? time1)
#f
(if (null? time2)
#t
(< time1 time2))))
;;SQUARE returns the square of its argument
(define-macro (square x)
`(expt ,x 2))
;;BALL-BALL-COLLISION-TIME returns the time at which the two given balls would
;;collide if neither interacted with any other objects, '() if never. This
;;calculation is performed by setting the distance between the balls to the sum
;;of their radi and solving for the contact time.
;;BALL1 = The first ball
;;BALL2 = The second ball
(define (ball-ball-collision-time ball1 ball2)
(let ((delta-x-velocity ;Cache the difference in the ball's
( - (ball-x-velocity ball2) ;velocities,
(ball-x-velocity ball1)))
(delta-y-velocity
( - (ball-y-velocity ball2)
(ball-y-velocity ball1)))
(radius-sum ;the sum of their radi,
(+ (ball-radius ball1)
(ball-radius ball2)))
(alpha-x ;and common subexpressions in the time
(- ;equation
(- (ball-collision-x-position
ball2)
(ball-collision-x-position
ball1))
(-
(* (ball-x-velocity ball2)
(ball-collision-time
ball2))
(* (ball-x-velocity ball1)
(ball-collision-time
ball1)))))
(alpha-y
(-
(- (ball-collision-y-position
ball2)
(ball-collision-y-position
ball1))
(-
(* (ball-y-velocity ball2)
(ball-collision-time
ball2))
(* (ball-y-velocity ball1)
(ball-collision-time
ball1))))))
(let* ((delta-velocity-magnitude-squared
(+ (square
delta-x-velocity)
(square
delta-y-velocity)))
(discriminant
(- (* (square radius-sum)
delta-velocity-magnitude-squared)
(square
(- (* delta-y-velocity
alpha-x)
(* delta-x-velocity
alpha-y))))))
(if (or (negative? discriminant) ;If the balls don't colloide:
(zero?
delta-velocity-magnitude-squared))
'() ;Return infinity
(let ((time ;Else, calculate the collision time
(/
(- 0
(+ (sqrt discriminant)
(+
(* delta-x-velocity
alpha-x)
(* delta-y-velocity
alpha-y))))
(+ (square
delta-x-velocity)
(square
delta-y-velocity)))))
(if (and ;If the balls collide in the future:
(time-<?
(ball-collision-time
ball1)
time)
(time-<?
(ball-collision-time
ball2)
time))
time ;Return the collision time
'())))))) ;Else, return that they never collide
;;BALL-BUMPER-COLLISION-TIME returns the time at which the given ball would
;;collide with the given bumper if the ball didn't interacted with any other
;;objects, '() if never. This is done by first calculating the time at which
;;the ball would collide with a bumper of infinite length and then checking if
;;the collision position represents a portion of the actual bumper.
;;BALL = The ball
;;BUMPER = The bumper
(define (ball-bumper-collision-time ball bumper)
(let ((delta-x-bumper ;Collision time with the bumper of
(- (bumper-x2 bumper) ;infinite extent is calculated by
(bumper-x1 bumper))) ;setting the distance between the ball
(delta-y-bumper ;and the bumper to be the radius of the
(- (bumper-y2 bumper) ;ball and solving for the time. The
(bumper-y1 bumper)))) ;distance is calculated by |aXb|/|a|,
(let ((bumper-length-squared ;where 'a' is the vector from one end
(+ (square delta-x-bumper) ;of the bumper to the other and 'b' is
(square delta-y-bumper))) ;the vector from the first end of the
(denominator ;bumper to the center of the ball
(- (* (ball-y-velocity ball)
delta-x-bumper)
(* (ball-x-velocity ball)
delta-y-bumper))))
(if (zero? denominator) ;If the ball's motion is parallel to
;the bumper:
'() ;Return infinity
(let ((delta-t ;Calculate the collision time
(-
(/
(+
(*
(- (ball-collision-x-position
ball)
(bumper-x1 bumper))
delta-y-bumper)
(*
(- (ball-collision-y-position
ball)
(bumper-y1 bumper))
delta-x-bumper))
denominator)
(/
(* (ball-radius
ball)
(sqrt
bumper-length-squared))
(abs denominator)))))
(if (not (positive? ;If the ball is moving away from the
delta-t)) ;bumper:
'() ;Return infinity
(let ((ball-x-contact ;Whether the ball contacts the actual
(+ (ball-collision-x-position ;bumper of limited extent
ball) ;will be determined by comparing |b.a|
(* (ball-x-velocity ;with |a|^2
ball)
delta-t)))
(ball-y-contact
(+ (ball-collision-y-position
ball)
(* (ball-y-velocity
ball)
delta-t))))
(let ((delta-x-ball
(- ball-x-contact
(bumper-x1
bumper)))
(delta-y-ball
(- ball-y-contact
(bumper-y1
bumper))))
(let ((dot-product
(+
(* delta-x-ball
delta-x-bumper)
(* delta-y-ball
delta-y-bumper))))
(if (or ;If the ball misses the bumper on
(negative? ;either end:
dot-product)
(> dot-product
bumper-length-squared))
'() ;Return infinity
(+ delta-t ;Else, return the contact time
(ball-collision-time
ball))))))))))))
;;BALL-COLLISION-PROCEDURE calculates the new velocities of the given balls
;;based on their collision at the given time. Also, tells all other balls
;;about the new trajectories of these balls so they can update their event
;;queues
;;BALL1 = The first ball
;;BALL2 = The second ball
;;COLLISION-TIME = The collision time
;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball
(define (ball-collision-procedure ball1 ball2 collision-time
global-event-queue)
(queue-remove ;Remove the earliest event associated
(ball-global-event-queue-record ;with each ball from the global event
ball1)) ;queue
(queue-remove
(ball-global-event-queue-record
ball2))
(let ((ball1-collision-x-position ;Calculate the positions of both balls
(+ (ball-collision-x-position ;when they collide
ball1)
(* (ball-x-velocity
ball1)
(- collision-time
(ball-collision-time
ball1)))))
(ball1-collision-y-position
(+ (ball-collision-y-position
ball1)
(* (ball-y-velocity
ball1)
(- collision-time
(ball-collision-time
ball1)))))
(ball2-collision-x-position
(+ (ball-collision-x-position
ball2)
(* (ball-x-velocity
ball2)
(- collision-time
(ball-collision-time
ball2)))))
(ball2-collision-y-position
(+ (ball-collision-y-position
ball2)
(* (ball-y-velocity
ball2)
(- collision-time
(ball-collision-time
ball2))))))
(let ((delta-x ;Calculate the displacements of the
(- ball2-collision-x-position ;centers of the two balls
ball1-collision-x-position))
(delta-y
(- ball2-collision-y-position
ball1-collision-y-position)))
(let* ((denominator ;Calculate the angle of the line
(sqrt (+ (square ;joining the centers at the collision
delta-x) ;time with the x-axis (this line is
(square ;the normal to the balls at the
delta-y)))) ;collision point)
(cos-theta
(/ delta-x denominator))
(sin-theta
(/ delta-y denominator)))
(let ((ball1-old-normal-velocity ;Convert the velocities of the balls
(+ (* (ball-x-velocity ;into the coordinate system defined by
ball1) ;the normal and tangential lines at
cos-theta) ;the collision point
(* (ball-y-velocity
ball1)
sin-theta)))
(ball1-tang-velocity
(- (* (ball-y-velocity
ball1)
cos-theta)
(* (ball-x-velocity
ball1)
sin-theta)))
(ball2-old-normal-velocity
(+ (* (ball-x-velocity
ball2)
cos-theta)
(* (ball-y-velocity
ball2)
sin-theta)))
(ball2-tang-velocity
(- (* (ball-y-velocity
ball2)
cos-theta)
(* (ball-x-velocity
ball2)
sin-theta)))
(mass1 (ball-mass
ball1))
(mass2 (ball-mass
ball2)))
(let ((ball1-new-normal-velocity ;Calculate the new velocities
(/ ;following the collision (the
(+ ;tangential velocities are unchanged
(* ;because the balls are assumed to be
(* 2 ;frictionless)
mass2)
ball2-old-normal-velocity)
(*
(- mass1 mass2)
ball1-old-normal-velocity))
(+ mass1 mass2)))
(ball2-new-normal-velocity
(/
(+
(*
(* 2
mass1)
ball1-old-normal-velocity)
(*
(- mass2 mass1)
ball2-old-normal-velocity))
(+ mass1 mass2))))
(set-ball-x-velocity! ;Store data about the collision in the
ball1 ;structure for each ball after
(- (* ball1-new-normal-velocity ;converting the information back
cos-theta) ;to the x,y frame
(* ball1-tang-velocity
sin-theta)))
(set-ball-y-velocity!
ball1
(+ (* ball1-new-normal-velocity
sin-theta)
(* ball1-tang-velocity
cos-theta)))
(set-ball-x-velocity!
ball2
(- (* ball2-new-normal-velocity
cos-theta)
(* ball2-tang-velocity
sin-theta)))
(set-ball-y-velocity!
ball2
(+ (* ball2-new-normal-velocity
sin-theta)
(* ball2-tang-velocity
cos-theta)))
(set-ball-collision-time!
ball1
collision-time)
(set-ball-collision-time!
ball2
collision-time)
(set-ball-collision-x-position!
ball1
ball1-collision-x-position)
(set-ball-collision-y-position!
ball1
ball1-collision-y-position)
(set-ball-collision-x-position!
ball2
ball2-collision-x-position)
(set-ball-collision-y-position!
ball2
ball2-collision-y-position))))))
(newline)
(display "Ball ")
(display (ball-number ball1))
(display " collides with ball ")
(display (ball-number ball2))
(display " at time ")
(display (ball-collision-time ball1))
(newline)
(display " Ball ")
(display (ball-number ball1))
(display " has a new velocity of ")
(display (ball-x-velocity ball1))
(display ",")
(display (ball-y-velocity ball1))
(display " starting at ")
(display (ball-collision-x-position ball1))
(display ",")
(display (ball-collision-y-position ball1))
(newline)
(display " Ball ")
(display (ball-number ball2))
(display " has a new velocity of ")
(display (ball-x-velocity ball2))
(display ",")
(display (ball-y-velocity ball2))
(display " starting at ")
(display (ball-collision-x-position ball2))
(display ",")
(display (ball-collision-y-position ball2))
(recalculate-collisions ball1 global-event-queue)
(recalculate-collisions ball2 global-event-queue))
;;BUMPER-COLLISION-PROCEDURE calculates the new velocity of the given ball
;;following its collision with the given bumper at the given time. Also, tells
;;other balls about the new trajectory of the given ball so they can update
;;their event queues.
;;BALL = The ball
;;BUMPER = The bumper
;;COLLISION-TIME = The collision time
;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball
(define (bumper-collision-procedure ball bumper collision-time
global-event-queue)
(queue-remove ;Remove the earliest event associated
(ball-global-event-queue-record ;with the ball from the global event
ball)) ;queue
(let ((delta-x-bumper ;Compute the bumper's delta-x
(- (bumper-x2 bumper)
(bumper-x1 bumper)))
(delta-y-bumper ;delta-y
(- (bumper-y2 bumper)
(bumper-y1 bumper))))
(let ((bumper-length ;length
(sqrt
(+ (square
delta-x-bumper)
(square
delta-y-bumper)))))
(let ((cos-theta ;and cosine and sine of its angle with
(/ delta-x-bumper ;respect to the positive x-axis
bumper-length))
(sin-theta
(/ delta-y-bumper
bumper-length))
(x-velocity ;Cache the ball's velocity in the x,y
(ball-x-velocity ball)) ;frame
(y-velocity
(ball-y-velocity ball)))
(let ((tang-velocity ;Calculate the ball's velocity in the
(+ (* x-velocity ;bumper frame
cos-theta)
(* y-velocity
sin-theta)))
(normal-velocity
(- (* y-velocity
cos-theta)
(* x-velocity
sin-theta))))
(set-ball-collision-x-position! ;Store the collision position
ball
(+ (ball-collision-x-position
ball)
(* (- collision-time
(ball-collision-time
ball))
(ball-x-velocity
ball))))
(set-ball-collision-y-position!
ball
(+ (ball-collision-y-position
ball)
(* (- collision-time
(ball-collision-time
ball))
(ball-y-velocity
ball))))
(set-ball-x-velocity! ;Calculate the new velocity in the
ball ;x,y frame based on the fact that
(+ (* tang-velocity ;tangential velocity is unchanged and
cos-theta) ;the normal velocity is inverted when
(* normal-velocity ;the ball collides with the bumper
sin-theta)))
(set-ball-y-velocity!
ball
(- (* tang-velocity
sin-theta)
(* normal-velocity
cos-theta)))
(set-ball-collision-time!
ball
collision-time)))))
(newline)
(display "Ball ")
(display (ball-number ball))
(display " collides with bumper ")
(display (bumper-number bumper))
(display " at time ")
(display (ball-collision-time ball))
(newline)
(display " Ball ")
(display (ball-number ball))
(display " has a new velocity of ")
(display (ball-x-velocity ball))
(display ",")
(display (ball-y-velocity ball))
(display " starting at ")
(display (ball-collision-x-position ball))
(display ",")
(display (ball-collision-y-position ball))
(recalculate-collisions ball global-event-queue))
;;RECALCULATE-COLLISIONS removes all old collisions for the given ball from
;;all other balls' event queues and calcultes new collisions for these balls
;;and places them on the event queues. Also, updates the global event queue if
;;the recalculation of the collision effects the earliest collision for any
;;other balls.
;;BALL = The ball whose collisions are being recalculated
;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball
(define (recalculate-collisions ball global-event-queue)
(clear-queue (ball-event-queue ;Clear the queue of events for this
ball)) ;ball as they have all changed
(let ((event-queue ;Calculate all ball collision events
(ball-event-queue ball))) ;with balls of lower number
(let ((ball-vector
(ball-ball-vector ball)))
(do ((i (-1+ (ball-number ball))
(-1+ i)))
((negative? i))
(let ((ball2-queue-record
(vector-ref
ball-vector
i)))
(set-event-queue-record-collision-time!
ball2-queue-record
(ball-ball-collision-time
ball
(event-queue-record-object
ball2-queue-record)))
(queue-insert
event-queue
ball2-queue-record))))
(let ((bumper-vector ;Calculate all bumper collision events
(ball-bumper-vector ball)))
(do ((i (-1+ (vector-length
bumper-vector))
(-1+ i)))
((negative? i))
(let ((bumper-queue-record
(vector-ref
bumper-vector
i)))
(set-event-queue-record-collision-time!
bumper-queue-record
(ball-bumper-collision-time
ball
(event-queue-record-object
bumper-queue-record)))
(queue-insert
event-queue
bumper-queue-record))))
(let ((global-queue-record ;Get the global event queue record
(ball-global-event-queue-record ;for this ball
ball)))
(set-event-queue-record-collision-time! ;Set the new earliest event time
global-queue-record ;for this ball
(if (empty-queue? event-queue)
'()
(event-queue-record-collision-time
(queue-smallest event-queue))))
(queue-insert ;Enqueue on the global event queue
global-event-queue ;the earliest event between this ball
global-queue-record))) ;and any ball of lower number or any
;bumper
(for-each ;For each ball on the ball list:
(lambda (ball2)
(let ((ball2-event-queue
(ball-event-queue ball2)))
(let ((alter-global-event-queue? ;Set flag to update global event queue
(and ;if the earliest event for ball2 was
(not (empty-queue? ;with the deflected ball
ball2-event-queue))
(eq? ball
(event-queue-record-object
(queue-smallest
ball2-event-queue)))))
(ball-event-queue-record ;Get the queue record for the deflected
(vector-ref ;ball for this ball
(ball-ball-vector
ball2)
(ball-number ball))))
(queue-remove ;Remove the queue record for the
ball-event-queue-record) ;deflected ball
(set-event-queue-record-collision-time! ;Recalculate the collision
ball-event-queue-record ;time for this ball and the deflected
(ball-ball-collision-time ;ball
ball
ball2))
(queue-insert ;Enqueue the new collision event
ball2-event-queue
ball-event-queue-record)
(if (or alter-global-event-queue? ;If the earliest collision event for
(eq? ball ;this ball has changed:
(event-queue-record-object
(queue-smallest
ball2-event-queue))))
(let ((queue-record ;Remove the old event from the global
(ball-global-event-queue-record ;event queue and replace it
ball2))) ;with the new event
(set-event-queue-record-collision-time!
queue-record
(event-queue-record-collision-time
(queue-smallest
ball2-event-queue)))
(queue-remove
queue-record)
(queue-insert
global-event-queue
queue-record))))))
(ball-ball-list ball)))
;;SIMULATE performs the billiard ball simulation for the given ball list and
;;bumper list until the specified time.
;;BALL-LIST = A list of balls
;;BUMPER-LIST = A list of bumpers
;;END-TIME = The time at which the simulation is to terminate
(define (simulate ball-list bumper-list end-time)
(let ((num-of-balls ;Cache the number of balls and bumpers
(length ball-list))
(num-of-bumpers
(length bumper-list))
(global-event-queue ;Build the global event queue
(make-sorted-queue
collision-time-<?)))
(let ((complete-ball-vector ;Build a vector for the balls
(make-vector
num-of-balls)))
(let loop ((ball-num 0) ;For each ball:
(ball-list ball-list))
(if (not (null? ball-list))
(let ((ball (car ball-list)))
(set-ball-number! ;Store the ball's number
ball
ball-num)
(vector-set! ;Place it in the ball vector
complete-ball-vector
ball-num
ball)
(set-ball-ball-list! ;Save the list of balls with ball
ball ;numbers greater than the current ball
(cdr ball-list))
(display-ball-state
ball)
(loop
(1+ ball-num)
(cdr ball-list)))))
(let loop ((bumper-num 0) ;For each bumper:
(bumper-list
bumper-list))
(if (not (null? bumper-list))
(sequence
(set-bumper-number! ;Store the bumper's number
(car bumper-list)
bumper-num)
(display-bumper-state
(car bumper-list))
(loop
(1+ bumper-num)
(cdr bumper-list)))))
(do ((ball-num 0 (1+ ball-num))) ;For each ball:
((= ball-num num-of-balls))
(let* ((ball (vector-ref ;Cache a reference to the ball
complete-ball-vector
ball-num))
(ball-vector ;Build a vector for the queue records
(make-vector ;of balls with smaller numbers than
ball-num)) ;this ball
(bumper-vector ;Build a vector for the queue records
(make-vector ;of bumpers
num-of-bumpers))
(event-queue ;Build an event queue for this ball
(ball-event-queue
ball)))
(set-ball-ball-vector! ;Install the vector of ball queue
ball ;records
ball-vector)
(do ((i 0 (1+ i))) ;For each ball of smaller number than
((= i ball-num)) ;the current ball:
(let* ((ball2 ;Cache the ball
(vector-ref
complete-ball-vector
i))
(queue-record ;Create a queue record for this ball
(make-event-queue-record ;based on the collision time
'() ;of the two balls
'()
ball2
(ball-ball-collision-time
ball
ball2))))
(vector-set! ;Install the queue record in the ball
ball-vector ;vector for this ball
i
queue-record)
(queue-insert ;Insert the queue record into the event
event-queue ;queue for this ball
queue-record)))
(set-ball-bumper-vector! ;Install the vector of bumper queue
ball ;records
bumper-vector)
(let loop ((bumper-num 0)
(bumper-list
bumper-list))
(if (not (null? bumper-list))
(let* ((bumper ;Cache the bumper
(car
bumper-list))
(queue-record ;Create a queue record for this bumper
(make-event-queue-record ;based on the collision time
'() ;of the current ball and this bumper
'()
bumper
(ball-bumper-collision-time
ball
bumper))))
(vector-set! ;Install the queue record in the bumper
bumper-vector ;vector for this ball
bumper-num
queue-record)
(queue-insert ;Insert the queue record into the event
event-queue ;queue for this ball
queue-record)
(loop
(1+ bumper-num)
(cdr bumper-list)))))
(let ((queue-record ;Build a global event queue record for
(make-event-queue-record ;the earliest event on this ball's
'() ;event queue
'()
ball
(if (empty-queue?
event-queue)
'()
(event-queue-record-collision-time
(queue-smallest
event-queue))))))
(set-ball-global-event-queue-record! ;Store this queue record in
ball ;the frame for this ball
queue-record)
(queue-insert ;Insert this queue record in the global
global-event-queue ;event queue
queue-record)))))
(actually-simulate ;Now that all of the data structures
global-event-queue ;have been built, actually start the
end-time))) ;simulation
;;DISPLAY-BALL-STATE displays the ball number, mass, radius, position, and
;;velocity of the given ball
;;BALL = The ball whose state is to be displayed
(define (display-ball-state ball)
(newline)
(display "Ball ")
(display (ball-number ball))
(display " has mass ")
(display (ball-mass ball))
(display " and radius ")
(display (ball-radius ball))
(newline)
(display " Its position at time ")
(display (ball-collision-time ball))
(display " was ")
(display (ball-collision-x-position ball))
(display ",")
(display (ball-collision-y-position ball))
(display " and its velocity is ")
(display (ball-x-velocity ball))
(display ",")
(display (ball-y-velocity ball)))
;;DISPLAY-BUMPER-STATE displays the bumper number and position of the given
;;bumper
;;BUMPER = The bumper whose state is to be displayed
(define (display-bumper-state bumper)
(newline)
(display "Bumper ")
(display (bumper-number bumper))
(display " extends from ")
(display (bumper-x1 bumper))
(display ",")
(display (bumper-y1 bumper))
(display " to ")
(display (bumper-x2 bumper))
(display ",")
(display (bumper-y2 bumper)))
;;ACTUALLY-SIMULATE performs the actual billiard ball simulation
;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball.
;; Contains a single event for each ball which is the
;; earliest collision it would have with a ball of a
;; smaller number or a bumper, if no other collisions took
;; place first.
;;END-TIME = The time at which the simulation should be terminated
(define (actually-simulate global-event-queue end-time)
(letrec ((loop
(lambda ()
(let* ((record ;Get the globally earliest event and
(queue-smallest ;its time
global-event-queue))
(collision-time
(event-queue-record-collision-time
record)))
(if (not ;If this event happens before the
(time-<? ;simulation termination time:
end-time
collision-time))
(let* ((ball ;Get the ball involved in the event,
(event-queue-record-object
record))
(ball-queue ;the queue of events for that ball,
(ball-event-queue
ball))
(other-object ;and the first object with which the
(event-queue-record-object ;ball interacts
(queue-smallest
ball-queue))))
((simulation-object-collision-procedure ;Process this
other-object) ;globally earliest collision
ball
other-object
collision-time
global-event-queue)
(loop))))))) ;Process the next interaction
(loop)))