1339 lines
45 KiB
Scheme
1339 lines
45 KiB
Scheme
;;; 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 (square x)
|
||
(* x x))
|
||
|
||
|
||
;;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)))
|
||
|
||
|
||
(require 'cscheme)
|
||
(set! autoload-notify? #f)
|
||
|
||
(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))
|
||
100)
|
||
|
||
(newline)
|