Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!tut.cis.ohio-state.edu!bloom-beacon!SESAME.STANFORD.EDU!mkatz
From: mkatz@SESAME.STANFORD.EDU (Morris Katz)
Newsgroups: comp.lang.scheme
Subject: Billiard Ball Simulator
Message-ID: <8903211707.AA12277@sesame.Stanford.EDU>
Date: 21 Mar 89 17:07:17 GMT
Sender: daemon@bloom-beacon.MIT.EDU
Organization: The Internet
Lines: 1345

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)))