1;;; BILLIARD.SCM: This file contains code for a very simple billiard ball 2;;; simulator. The simulation takes place in two dimensions. 3;;; The balls are really disks in that their height is not taken 4;;; into account. All interactions are assumed to be 5;;; frictionless so spin in irrelevant and not accounted for. 6;;; (See section on limitations.) 7;;; 8;;; NOTES: A simulation is initiated by creating a number of balls and bumpers 9;;; and and specifying a duration for the simulation. For each ball, 10;;; its mass, radius, initial position, and initial velocity must be 11;;; specified. For each bumper, the location of its two ends must be 12;;; specified. (Bumpers are assumed to have zero width.) 13;;; 14;;; A sample run might be started as follows: 15;;; (simulate 16;;; (list (make-ball 2 1 9 5 -1 -1) 17;;; (make-ball 4 2 2 5 1 -1)) 18;;; (list (make-bumper 0 0 0 10) 19;;; (make-bumper 0 0 10 0) 20;;; (make-bumper 0 10 10 10) 21;;; (make-bumper 10 0 10 10)) 22;;; 30) 23;;; 24;;; It would create one billiard ball of mass 2 and radius 1 at position 25;;; (9, 5) with initial velocity (-1, -1) and a second ball of mass 4 26;;; and radius 2 at position (2, 5) with initial velocity (1, -1). The 27;;; table would be a 10X10 square. (See diagram below) 28;;; 29;;; +---------------------------+ 30;;; | | 31;;; | | 32;;; | XXXX | 33;;; | XXXXXXXX XX | 34;;; |XXXXXX4XXXXX XXX2XX| 35;;; | XXXXXXXX /XX | 36;;; | XXXX \ | 37;;; | | 38;;; | | 39;;; +---------------------------+ 40;;; 41;;; LIMITATIONS: This simulator does not handle 3 body problems correctly. If 42;;; 3 objects interact at one time, only the interactions of 2 of 43;;; the bodies will be accounted for. This can lead to strange 44;;; effects like balls tunneling through walls and other balls. 45;;; It is also possible to get balls bouncing inside of each 46;;; other in this way. 47;;; 48 49 50;;MAKE-QUEUE-RECORD returns a queue record with the given next, previous, and 51;;value values 52;;NEXT = The next record pointer 53;;PREV = The previous record pointer 54;;REST = A list of values for any optional fields (this can be used for 55;; creating structure inheritance) 56(define-macro (make-queue-record next prev . rest) 57 `(vector ,next ,prev ,@rest)) 58 59;;QUEUE-RECORD-NEXT returns the next field of the given queue record 60;;QUEUE-RECORD = The queue record whose next field is to be returned 61(define-macro (queue-record-next queue-record) 62 `(vector-ref ,queue-record 0)) 63 64;;SET-QUEUE-RECORD-NEXT! sets the next field of the given queue record 65;;QUEUE-RECORD = The queue record whose next field is to be set 66;;VALUE = The value to which the next field is to be set 67(define-macro (set-queue-record-next! queue-record value) 68 `(vector-set! ,queue-record 0 ,value)) 69 70;;QUEUE-RECORD-PREV returns the prev field of the given queue record 71;;QUEUE-RECORD = The queue record whose prev field is to be returned 72(define-macro (queue-record-prev queue-record) 73 `(vector-ref ,queue-record 1)) 74 75;;SET-QUEUE-RECORD-PREV! sets the prev field of the given queue record 76;;QUEUE-RECORD = The queue record whose prev field is to be set 77;;VALUE = The value to which the prev field is to be set 78(define-macro (set-queue-record-prev! queue-record value) 79 `(vector-set! ,queue-record 1 ,value)) 80 81;;QUEUE-RECORD-LEN returns the length of a queue record which has no optional 82;;fields 83(define-macro (queue-record-len) 2) 84 85;;QUEUE-HEAD returns a dummy record at the end of the queue with the record 86;;with the smallest key. 87;;QUEUE = the queue whose head record is to be returned 88(define-macro (queue-head queue) 89 `(vector-ref ,queue 0)) 90 91;;QUEUE-TAIL returns a dummy record at the end of the queue with the record 92;;with the largest key. 93;;QUEUE = the queue whose tail record is to be returned 94(define-macro (queue-tail queue) 95 `(vector-ref ,queue 1)) 96 97;;QUEUE-<? returns the less-than comparitor to be used in sorting 98;;records into the queue 99;;QUEUE = The queue whose comparitor is to be returned 100(define-macro (queue-<? queue) 101 `(vector-ref ,queue 2)) 102 103 104;;MAKE-SORTED-QUEUE returns a queue object. A queue header is a vector which 105;;contains a head pointer, a tail pointer, and a less-than comparitor. 106;;QUEUE-<? = A predicate for sorting queue items 107(define (make-sorted-queue queue-<?) 108 (let ((queue 109 (vector 110 (make-queue-record ;The queue head record has no initial 111 '() ;next, previous, or value values 112 '()) 113 (make-queue-record ;The queue tail record has no intial 114 '() ;next, previous, or value values 115 '()) 116 queue-<?))) 117 (set-queue-record-next! 118 (queue-head queue) 119 (queue-tail queue)) 120 (set-queue-record-prev! 121 (queue-tail queue) 122 (queue-head queue)) 123 queue)) 124 125;;MAKE-EVENT-QUEUE-RECORD returns an event queue record with the given next, 126;;previous, object, and collision-time values 127;;NEXT = The next record pointer 128;;PREV = The previous record pointer 129;;OBJECT = The simulation object associated with this record 130;;COLLISION-TIME = The collision time for this object 131(define-macro (make-event-queue-record next prev object collision-time) 132 `(make-queue-record ,next ,prev ,object ,collision-time)) 133 134;;EVENT-QUEUE-RECORD-OBJECT returns the object associated with the given record 135;;QUEUE-RECORD = The queue record whose object field is to be returned 136(define-macro (event-queue-record-object queue-record) 137 `(vector-ref ,queue-record ,(queue-record-len))) 138 139;;EVENT-QUEUE-COLLISION-TIME returns the collision time associated with the 140;;given queue record 141;;QUEUE-RECORD = The queue record whose collision time field is to be returned 142(define-macro (event-queue-record-collision-time queue-record) 143 `(vector-ref ,queue-record ,(1+ (queue-record-len)))) 144 145;;SET-EVENT-QUEUE-COLLISION-TIME! sets the collision time associated with the 146;;given queue record 147;;QUEUE-RECORD = The queue record whose collision time field is to be returned 148;;VALUE = The value to which it is to be set 149(define-macro (set-event-queue-record-collision-time! queue-record value) 150 `(vector-set! ,queue-record ,(1+ (queue-record-len)) ,value)) 151 152 153;;QUEUE-INSERT inserts the given record in the given queue based on its value 154;;QUEUE = The queue into which the record is to be inserted 155;;QUEUE-RECORD = The record to be inserted in the queue 156(define (queue-insert queue queue-record) 157 (define (actual-insert insert-record next-record) 158 (if (or ;If the insert position has been found 159 (eq? next-record ;or the end on the queue has been 160 (queue-tail queue)) ;reached 161 ((queue-<? queue) 162 insert-record 163 next-record)) 164 (sequence ;Link the insert record into the queue 165 (set-queue-record-next! ;just prior to next-record 166 (queue-record-prev 167 next-record) 168 insert-record) 169 (set-queue-record-prev! 170 insert-record 171 (queue-record-prev 172 next-record)) 173 (set-queue-record-next! 174 insert-record 175 next-record) 176 (set-queue-record-prev! 177 next-record 178 insert-record)) 179 (actual-insert ;Else, continue searching for the 180 insert-record ;insert position 181 (queue-record-next 182 next-record)))) 183 (actual-insert ;Search for the correct position to 184 queue-record ;perform the insert starting at the 185 (queue-record-next ;queue head and perform the insert 186 (queue-head queue)))) ;once this position has been found 187 188;;QUEUE-REMOVE removes the given queue record from its queue 189;;QUEUE-RECORD = The record to be removed from the queue 190(define (queue-remove queue-record) 191 (set-queue-record-next! 192 (queue-record-prev 193 queue-record) 194 (queue-record-next 195 queue-record)) 196 (set-queue-record-prev! 197 (queue-record-next 198 queue-record) 199 (queue-record-prev 200 queue-record))) 201 202;;QUEUE-SMALLEST returns the queue record with the smallest key on the given 203;;queue 204;;QUEUE = The queue from which the smallest record is to be extracted 205(define (queue-smallest queue) 206 (queue-record-next 207 (queue-head queue))) 208 209 210;;CLEAR-QUEUE! clears the given queue by destructively removing all the records 211;;QUEUE = The queue to be cleared 212(define (clear-queue queue) 213 (set-queue-record-next! 214 (queue-head queue) 215 (queue-tail queue)) 216 (set-queue-record-prev! 217 (queue-tail queue) 218 (queue-head queue))) 219 220;;EMPTY-QUEUE? returns true if the given queue is empty 221;;QUEUE = The queue to be tested for emptiness 222(define (empty-queue? queue) 223 (eq? (queue-record-next 224 (queue-head queue)) 225 (queue-tail queue))) 226 227 228;;MAKE-SIMULATION-OBJECT returns a simulation object containing the given 229;;fields 230;;COLLISION-PROCEDURE = A function for processing information about a potential 231;; collision between this object and some ball 232;;REST = A list of values for any optional fields (this can be used for 233;; creating structure inheritance) 234(define-macro (make-simulation-object collision-procedure . rest) 235 `(vector ,collision-procedure ,@rest)) 236 237;;SIMULATION-OBJECT-COLLLISION-PROCEDURE returns the collision procedure for 238;;the given simulation object 239;;OBJECT = The object whose collision procedure is to be returned 240(define-macro (simulation-object-collision-procedure object) 241 `(vector-ref ,object 0)) 242 243;;SIMULATION-OBJECT-LEN returns the length of a simulation object which has no 244;;optional fields 245(define-macro (simulation-object-len) 1) 246 247 248;;ACTUAL-MAKE-BALL returns a ball object 249;;BALL-NUMBER = An index into the ball vector for this ball 250;;MASS = The ball's mass 251;;RADIUS = The ball's radius 252;;PX = The x-coordinate of the ball's initial position 253;;PY = The y-coordinate of the ball's initial position 254;;VX = The x-coordinate of the ball's initial velocity 255;;VY = The y-coordinate of the ball's initial velocity 256(define-macro (actual-make-ball ball-number mass radius px py vx vy) 257 `(make-simulation-object 258 ball-collision-procedure ;The collision procedure for a ball 259 ,ball-number 260 ,mass 261 ,radius 262 (make-sorted-queue ;The event queue 263 collision-time-<?) 264 0 ;Time of last collision 265 ,px ;Position of last collision 266 ,py ; " 267 ,vx ;Velocity following last colliosion 268 ,vy ; " 269 '() ;No vector of queue records for ball's 270 ;with smaller numbers 271 '() ;No vector of queue records for bumpers 272 '() ;No list of balls with larger numbers 273 '())) ;No global event queue record, yet 274 275(define (make-ball mass radius px py vx vy) 276 (actual-make-ball '() mass radius px py vx vy)) 277 278;;BALL-NUMBER returns the index of the given ball 279;;BALL = The ball whose index is to be returned 280(define-macro (ball-number ball) 281 `(vector-ref ,ball ,(simulation-object-len))) 282 283;;SET-BALL-NUMBER! set the index of the given ball to the given value 284;;BALL = The ball whose index is to be set 285;;VALUE = The value to which it is to be set 286(define-macro (set-ball-number! ball value) 287 `(vector-set! ,ball ,(simulation-object-len) ,value)) 288 289;;BALL-MASS returns the mass of the given ball 290;;BALL = The ball whose mass is to be returned 291(define-macro (ball-mass ball) 292 `(vector-ref ,ball ,(+ (simulation-object-len) 1))) 293 294;;BALL-RADIUS returns the radius of the given ball 295;;BALL = The ball whose radius is to be returned 296(define-macro (ball-radius ball) 297 `(vector-ref ,ball ,(+ (simulation-object-len) 2))) 298 299;;BALL-EVENT-QUEUE returns the sort queue of collision events for the given 300;;ball 301;;BALL = The ball whose event is to be returned 302(define-macro (ball-event-queue ball) 303 `(vector-ref ,ball ,(+ (simulation-object-len) 3))) 304 305;;BALL-COLLISION-TIME returns the time of the last collision for the given ball 306;;BALL = The ball whose collision time is to be returned 307(define-macro (ball-collision-time ball) 308 `(vector-ref ,ball ,(+ (simulation-object-len) 4))) 309 310 311;;SET-BALL-COLLISION-TIME! sets the time of the last collision for the given 312;;ball 313;;BALL = The ball whose collision time is to be set 314;;VALUE = The value to which the ball's collision time is to be set 315(define-macro (set-ball-collision-time! ball value) 316 `(vector-set! ,ball ,(+ (simulation-object-len) 4) ,value)) 317 318;;BALL-COLLISION-X-POSITION returns the x-coordinate of the position of the 319;;last collision for the given ball 320;;BALL = The ball whose collision position is to be returned 321(define-macro (ball-collision-x-position ball) 322 `(vector-ref ,ball ,(+ (simulation-object-len) 5))) 323 324;;SET-BALL-COLLISION-X-POSITION! sets the x-coordinate of the position of the 325;;last collision for the given ball 326;;BALL = The ball whose collision position is to be set 327;;VALUE = The value to which the ball's collision position is to be set 328(define-macro (set-ball-collision-x-position! ball value) 329 `(vector-set! ,ball ,(+ (simulation-object-len) 5) ,value)) 330 331;;BALL-COLLISION-Y-POSITION returns the y-coordinate of the position of the 332;;last collision for the given ball 333;;BALL = The ball whose collision position is to be returned 334(define-macro (ball-collision-y-position ball) 335 `(vector-ref ,ball ,(+ (simulation-object-len) 6))) 336 337;;SET-BALL-COLLISION-Y-POSITION! sets the y-coordinate of the position of the 338;;last collision for the given ball 339;;BALL = The ball whose collision position is to be set 340;;VALUE = The value to which the ball's collision position is to be set 341(define-macro (set-ball-collision-y-position! ball value) 342 `(vector-set! ,ball ,(+ (simulation-object-len) 6) ,value)) 343 344;;BALL-X-VELOCITY returns the x-coordinate of the velocity of the given ball 345;;following its last collision 346;;BALL = The ball whose velocity is to be returned 347(define-macro (ball-x-velocity ball) 348 `(vector-ref ,ball ,(+ (simulation-object-len) 7))) 349 350;;SET-BALL-X-VELOCITY! sets the x-coordinate of the velocity of the given ball 351;;BALL = The ball whose velocity is to be set 352;;VALUE = The value to which the ball's velocity is to be set 353(define-macro (set-ball-x-velocity! ball value) 354 `(vector-set! ,ball ,(+ (simulation-object-len) 7) ,value)) 355 356;;BALL-Y-VELOCITY returns the y-coordinate of the velocity of the given ball 357;;following its last collision 358;;BALL = The ball whose velocity is to be returned 359(define-macro (ball-y-velocity ball) 360 `(vector-ref ,ball ,(+ (simulation-object-len) 8))) 361 362;;SET-BALL-Y-VELOCITY! sets the y-coordinate of the velocity of the given ball 363;;BALL = The ball whose velocity is to be set 364;;VALUE = The value to which the ball's velocity is to be set 365(define-macro (set-ball-y-velocity! ball value) 366 `(vector-set! ,ball ,(+ (simulation-object-len) 8) ,value)) 367 368 369;;BALL-BALL-VECTOR returns the vector of queue records for balls with smaller 370;;ball numbers 371;;BALL = The ball whose ball vector is to be returned 372(define-macro (ball-ball-vector ball) 373 `(vector-ref ,ball ,(+ (simulation-object-len) 9))) 374 375;;SET-BALL-BALL-VECTOR! sets the vector of queue records for balls with smaller 376;;ball numbers 377;;BALL = The ball whose ball vector is to be set 378;;VALUE = The vector to which the field is to be set 379(define-macro (set-ball-ball-vector! ball value) 380 `(vector-set! ,ball ,(+ (simulation-object-len) 9) ,value)) 381 382;;BALL-BUMPER-VECTOR returns the vector of queue records for bumpers 383;;BALL = The ball whose bumper vector is to be returned 384(define-macro (ball-bumper-vector ball) 385 `(vector-ref ,ball ,(+ (simulation-object-len) 10))) 386 387;;SET-BALL-BUMPER-VECTOR! sets the vector of queue records for bumpers 388;;BALL = The ball whose bumper vector is to be set 389;;VALUE = The vector to which the field is to be set 390(define-macro (set-ball-bumper-vector! ball value) 391 `(vector-set! ,ball ,(+ (simulation-object-len) 10) ,value)) 392 393;;BALL-BALL-LIST returns a list of balls with larger ball numbers than the 394;;given ball 395;;BALL = The ball whose ball list is to be returned 396(define-macro (ball-ball-list ball) 397 `(vector-ref ,ball ,(+ (simulation-object-len) 11))) 398 399;;SET-BALL-BALL-LIST! sets the list of balls with larger ball numbers than the 400;;given ball 401;;BALL = The ball whose ball list is to be set 402;;VALUE = The value to which the ball list is to be set 403(define-macro (set-ball-ball-list! ball value) 404 `(vector-set! ,ball ,(+ (simulation-object-len) 11) ,value)) 405 406;;BALL-GLOBAL-EVENT-QUEUE-RECORD returns the global event queue record for the 407;;given ball 408;;BALL = The ball whose global event queue record is to be returned 409(define-macro (ball-global-event-queue-record ball) 410 `(vector-ref ,ball ,(+ (simulation-object-len) 12))) 411 412;;SET-BALL-GLOBAL-EVENT-QUEUE-RECORD! set the global event queue record for the 413;;given ball to the given value 414;;BALL = The ball whose global event queue record is to be set 415;;VALUE = The value to which the global event queue record field is to be set 416(define-macro (set-ball-global-event-queue-record! ball value) 417 `(vector-set! ,ball ,(+ (simulation-object-len) 12) ,value)) 418 419 420 421;;ACTUAL-MAKE-BUMPER returns a bumper object 422;;BUMPER-NUMBER = An index into the bumper vector for this bumper 423;;X1 = The x-coordiante of one end of the bumper 424;;Y1 = The y-coordiante of one end of the bumper 425;;X2 = The x-coordiante of the other end of the bumper 426;;Y2 = The y-coordiante of the other end of the bumper 427(define-macro (actual-make-bumper bumper-number x1 y1 x2 y2) 428 `(make-simulation-object 429 bumper-collision-procedure ;The collision procedure for a bumper 430 ,bumper-number 431 ,x1 ;The bumper endpoints 432 ,y1 433 ,x2 434 ,y2)) 435 436(define (make-bumper x1 y1 x2 y2) 437 (actual-make-bumper '() x1 y1 x2 y2)) 438 439;;BUMPER-NUMBER returns the index of the given bumper 440;;BUMPER = The bumper whose index is to be returned 441(define-macro (bumper-number bumper) 442 `(vector-ref ,bumper ,(simulation-object-len))) 443 444;;SET-BUMPER-NUMBER! set the index of the given bumper to the given value 445;;BUMPER = The bumper whose index is to be set 446;;VALUE = The value to which it is to be set 447(define-macro (set-bumper-number! bumper value) 448 `(vector-set! ,bumper ,(simulation-object-len) ,value)) 449 450;;BUMPER-X1 returns the x-coordinate of one end of the given bumber 451;;BUMPER = the bumper whose x-coordinate is to be returned 452(define-macro (bumper-x1 bumper) 453 `(vector-ref ,bumper ,(1+ (simulation-object-len)))) 454 455;;SET-BUMPER-X1! sets the x-coordinate of one end of the given bumber 456;;BUMPER = the bumper whose x-coordinate is to be set 457;;VALUE = The value to which the bumpers x-coordinate is to be set 458(define-macro (set-bumper-x1! bumper value) 459 `(vector-set! ,bumper ,(1+ (simulation-object-len)) ,value)) 460 461;;BUMPER-Y1 returns the y-coordinate of one end of the given bumber 462;;BUMPER = the bumper whose y-coordinate is to be returned 463(define-macro (bumper-y1 bumper) 464 `(vector-ref ,bumper ,(+ (simulation-object-len) 2))) 465 466;;SET-BUMPER-Y1! sets the y-coordinate of one end of the given bumber 467;;BUMPER = the bumper whose y-coordinate is to be set 468;;VALUE = The value to which the bumpers y-coordinate is to be set 469(define-macro (set-bumper-y1! bumper value) 470 `(vector-set! ,bumper ,(+ (simulation-object-len) 2) ,value)) 471 472;;BUMPER-X2 returns the x-coordinate of the other end of the given bumber 473;;BUMPER = the bumper whose x-coordinate is to be returned 474(define-macro (bumper-x2 bumper) 475 `(vector-ref ,bumper ,(+ (simulation-object-len) 3))) 476 477;;SET-BUMPER-X2! sets the x-coordinate of the other end of the given bumber 478;;BUMPER = the bumper whose x-coordinate is to be set 479;;VALUE = The value to which the bumpers x-coordinate is to be set 480(define-macro (set-bumper-x2! bumper value) 481 `(vector-set! ,bumper ,(+ (simulation-object-len) 3) ,value)) 482 483 484;;BUMPER-Y2 returns the y-coordinate of the other end of the given bumber 485;;BUMPER = the bumper whose y-coordinate is to be returned 486(define-macro (bumper-y2 bumper) 487 `(vector-ref ,bumper ,(+ (simulation-object-len) 4))) 488 489;;SET-BUMPER-Y2! sets the y-coordinate of the other end of the given bumber 490;;BUMPER = the bumper whose y-coordinate is to be set 491;;VALUE = The value to which the bumpers y-coordinate is to be set 492(define-macro (set-bumper-y2! bumper value) 493 `(vector-set! ,bumper ,(+ (simulation-object-len) 4) ,value)) 494 495;;COLLISION-TIME-<? is a predicate which returns true if the first event queueu 496;;record represents a collision that will take place at an earlier time than 497;;the one for the second event queue record 498;;EVENT-QUEUE-RECORD1 = The first event queue record 499;;EVENT-QUEUE-RECORD2 = The second event queue record 500(define (collision-time-<? event-queue-record1 event-queue-record2) 501 (time-<? 502 (event-queue-record-collision-time 503 event-queue-record1) 504 (event-queue-record-collision-time 505 event-queue-record2))) 506 507;;TIME-<? is a predicate which returns true if the first time is smaller than 508;;the second. '() represents a time infinitly large. 509(define (time-<? time1 time2) 510 (if (null? time1) 511 #f 512 (if (null? time2) 513 #t 514 (< time1 time2)))) 515 516;;SQUARE returns the square of its argument 517(define (square x) 518 (* x x)) 519 520 521;;BALL-BALL-COLLISION-TIME returns the time at which the two given balls would 522;;collide if neither interacted with any other objects, '() if never. This 523;;calculation is performed by setting the distance between the balls to the sum 524;;of their radi and solving for the contact time. 525;;BALL1 = The first ball 526;;BALL2 = The second ball 527(define (ball-ball-collision-time ball1 ball2) 528 (let ((delta-x-velocity ;Cache the difference in the ball's 529 ( - (ball-x-velocity ball2) ;velocities, 530 (ball-x-velocity ball1))) 531 (delta-y-velocity 532 ( - (ball-y-velocity ball2) 533 (ball-y-velocity ball1))) 534 (radius-sum ;the sum of their radi, 535 (+ (ball-radius ball1) 536 (ball-radius ball2))) 537 (alpha-x ;and common subexpressions in the time 538 (- ;equation 539 (- (ball-collision-x-position 540 ball2) 541 (ball-collision-x-position 542 ball1)) 543 (- 544 (* (ball-x-velocity ball2) 545 (ball-collision-time 546 ball2)) 547 (* (ball-x-velocity ball1) 548 (ball-collision-time 549 ball1))))) 550 (alpha-y 551 (- 552 (- (ball-collision-y-position 553 ball2) 554 (ball-collision-y-position 555 ball1)) 556 (- 557 (* (ball-y-velocity ball2) 558 (ball-collision-time 559 ball2)) 560 (* (ball-y-velocity ball1) 561 (ball-collision-time 562 ball1)))))) 563 (let* ((delta-velocity-magnitude-squared 564 (+ (square 565 delta-x-velocity) 566 (square 567 delta-y-velocity))) 568 (discriminant 569 (- (* (square radius-sum) 570 delta-velocity-magnitude-squared) 571 (square 572 (- (* delta-y-velocity 573 alpha-x) 574 (* delta-x-velocity 575 alpha-y)))))) 576 577 578 (if (or (negative? discriminant) ;If the balls don't colloide: 579 (zero? 580 delta-velocity-magnitude-squared)) 581 '() ;Return infinity 582 (let ((time ;Else, calculate the collision time 583 (/ 584 (- 0 585 (+ (sqrt discriminant) 586 (+ 587 (* delta-x-velocity 588 alpha-x) 589 (* delta-y-velocity 590 alpha-y)))) 591 (+ (square 592 delta-x-velocity) 593 (square 594 delta-y-velocity))))) 595 (if (and ;If the balls collide in the future: 596 (time-<? 597 (ball-collision-time 598 ball1) 599 time) 600 (time-<? 601 (ball-collision-time 602 ball2) 603 time)) 604 time ;Return the collision time 605 '())))))) ;Else, return that they never collide 606 607;;BALL-BUMPER-COLLISION-TIME returns the time at which the given ball would 608;;collide with the given bumper if the ball didn't interacted with any other 609;;objects, '() if never. This is done by first calculating the time at which 610;;the ball would collide with a bumper of infinite length and then checking if 611;;the collision position represents a portion of the actual bumper. 612;;BALL = The ball 613;;BUMPER = The bumper 614(define (ball-bumper-collision-time ball bumper) 615 (let ((delta-x-bumper ;Collision time with the bumper of 616 (- (bumper-x2 bumper) ;infinite extent is calculated by 617 (bumper-x1 bumper))) ;setting the distance between the ball 618 (delta-y-bumper ;and the bumper to be the radius of the 619 (- (bumper-y2 bumper) ;ball and solving for the time. The 620 (bumper-y1 bumper)))) ;distance is calculated by |aXb|/|a|, 621 (let ((bumper-length-squared ;where 'a' is the vector from one end 622 (+ (square delta-x-bumper) ;of the bumper to the other and 'b' is 623 (square delta-y-bumper))) ;the vector from the first end of the 624 (denominator ;bumper to the center of the ball 625 (- (* (ball-y-velocity ball) 626 delta-x-bumper) 627 (* (ball-x-velocity ball) 628 delta-y-bumper)))) 629 (if (zero? denominator) ;If the ball's motion is parallel to 630 ;the bumper: 631 '() ;Return infinity 632 (let ((delta-t ;Calculate the collision time 633 (- 634 (/ 635 (+ 636 (* 637 (- (ball-collision-x-position 638 ball) 639 (bumper-x1 bumper)) 640 delta-y-bumper) 641 (* 642 (- (ball-collision-y-position 643 ball) 644 (bumper-y1 bumper)) 645 delta-x-bumper)) 646 denominator) 647 (/ 648 (* (ball-radius 649 ball) 650 (sqrt 651 bumper-length-squared)) 652 (abs denominator))))) 653 (if (not (positive? ;If the ball is moving away from the 654 delta-t)) ;bumper: 655 '() ;Return infinity 656 657 658 (let ((ball-x-contact ;Whether the ball contacts the actual 659 (+ (ball-collision-x-position ;bumper of limited extent 660 ball) ;will be determined by comparing |b.a| 661 (* (ball-x-velocity ;with |a|^2 662 ball) 663 delta-t))) 664 (ball-y-contact 665 (+ (ball-collision-y-position 666 ball) 667 (* (ball-y-velocity 668 ball) 669 delta-t)))) 670 (let ((delta-x-ball 671 (- ball-x-contact 672 (bumper-x1 673 bumper))) 674 (delta-y-ball 675 (- ball-y-contact 676 (bumper-y1 677 bumper)))) 678 (let ((dot-product 679 (+ 680 (* delta-x-ball 681 delta-x-bumper) 682 (* delta-y-ball 683 delta-y-bumper)))) 684 (if (or ;If the ball misses the bumper on 685 (negative? ;either end: 686 dot-product) 687 (> dot-product 688 bumper-length-squared)) 689 '() ;Return infinity 690 (+ delta-t ;Else, return the contact time 691 (ball-collision-time 692 ball)))))))))))) 693 694 695;;BALL-COLLISION-PROCEDURE calculates the new velocities of the given balls 696;;based on their collision at the given time. Also, tells all other balls 697;;about the new trajectories of these balls so they can update their event 698;;queues 699;;BALL1 = The first ball 700;;BALL2 = The second ball 701;;COLLISION-TIME = The collision time 702;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball 703(define (ball-collision-procedure ball1 ball2 collision-time 704 global-event-queue) 705 (queue-remove ;Remove the earliest event associated 706 (ball-global-event-queue-record ;with each ball from the global event 707 ball1)) ;queue 708 (queue-remove 709 (ball-global-event-queue-record 710 ball2)) 711 (let ((ball1-collision-x-position ;Calculate the positions of both balls 712 (+ (ball-collision-x-position ;when they collide 713 ball1) 714 (* (ball-x-velocity 715 ball1) 716 (- collision-time 717 (ball-collision-time 718 ball1))))) 719 (ball1-collision-y-position 720 (+ (ball-collision-y-position 721 ball1) 722 (* (ball-y-velocity 723 ball1) 724 (- collision-time 725 (ball-collision-time 726 ball1))))) 727 (ball2-collision-x-position 728 (+ (ball-collision-x-position 729 ball2) 730 (* (ball-x-velocity 731 ball2) 732 (- collision-time 733 (ball-collision-time 734 ball2))))) 735 (ball2-collision-y-position 736 (+ (ball-collision-y-position 737 ball2) 738 (* (ball-y-velocity 739 ball2) 740 (- collision-time 741 (ball-collision-time 742 ball2)))))) 743 (let ((delta-x ;Calculate the displacements of the 744 (- ball2-collision-x-position ;centers of the two balls 745 ball1-collision-x-position)) 746 (delta-y 747 (- ball2-collision-y-position 748 ball1-collision-y-position))) 749 750 751 (let* ((denominator ;Calculate the angle of the line 752 (sqrt (+ (square ;joining the centers at the collision 753 delta-x) ;time with the x-axis (this line is 754 (square ;the normal to the balls at the 755 delta-y)))) ;collision point) 756 (cos-theta 757 (/ delta-x denominator)) 758 (sin-theta 759 (/ delta-y denominator))) 760 (let ((ball1-old-normal-velocity ;Convert the velocities of the balls 761 (+ (* (ball-x-velocity ;into the coordinate system defined by 762 ball1) ;the normal and tangential lines at 763 cos-theta) ;the collision point 764 (* (ball-y-velocity 765 ball1) 766 sin-theta))) 767 (ball1-tang-velocity 768 (- (* (ball-y-velocity 769 ball1) 770 cos-theta) 771 (* (ball-x-velocity 772 ball1) 773 sin-theta))) 774 (ball2-old-normal-velocity 775 (+ (* (ball-x-velocity 776 ball2) 777 cos-theta) 778 (* (ball-y-velocity 779 ball2) 780 sin-theta))) 781 (ball2-tang-velocity 782 (- (* (ball-y-velocity 783 ball2) 784 cos-theta) 785 (* (ball-x-velocity 786 ball2) 787 sin-theta))) 788 (mass1 (ball-mass 789 ball1)) 790 (mass2 (ball-mass 791 ball2))) 792 (let ((ball1-new-normal-velocity ;Calculate the new velocities 793 (/ ;following the collision (the 794 (+ ;tangential velocities are unchanged 795 (* ;because the balls are assumed to be 796 (* 2 ;frictionless) 797 mass2) 798 ball2-old-normal-velocity) 799 (* 800 (- mass1 mass2) 801 ball1-old-normal-velocity)) 802 (+ mass1 mass2))) 803 804 805 (ball2-new-normal-velocity 806 (/ 807 (+ 808 (* 809 (* 2 810 mass1) 811 ball1-old-normal-velocity) 812 (* 813 (- mass2 mass1) 814 ball2-old-normal-velocity)) 815 (+ mass1 mass2)))) 816 (set-ball-x-velocity! ;Store data about the collision in the 817 ball1 ;structure for each ball after 818 (- (* ball1-new-normal-velocity ;converting the information back 819 cos-theta) ;to the x,y frame 820 (* ball1-tang-velocity 821 sin-theta))) 822 (set-ball-y-velocity! 823 ball1 824 (+ (* ball1-new-normal-velocity 825 sin-theta) 826 (* ball1-tang-velocity 827 cos-theta))) 828 (set-ball-x-velocity! 829 ball2 830 (- (* ball2-new-normal-velocity 831 cos-theta) 832 (* ball2-tang-velocity 833 sin-theta))) 834 (set-ball-y-velocity! 835 ball2 836 (+ (* ball2-new-normal-velocity 837 sin-theta) 838 (* ball2-tang-velocity 839 cos-theta))) 840 (set-ball-collision-time! 841 ball1 842 collision-time) 843 (set-ball-collision-time! 844 ball2 845 collision-time) 846 (set-ball-collision-x-position! 847 ball1 848 ball1-collision-x-position) 849 (set-ball-collision-y-position! 850 ball1 851 ball1-collision-y-position) 852 (set-ball-collision-x-position! 853 ball2 854 ball2-collision-x-position) 855 (set-ball-collision-y-position! 856 ball2 857 ball2-collision-y-position)))))) 858 859 860 (newline) 861 (display "Ball ") 862 (display (ball-number ball1)) 863 (display " collides with ball ") 864 (display (ball-number ball2)) 865 (display " at time ") 866 (display (ball-collision-time ball1)) 867 (newline) 868 (display " Ball ") 869 (display (ball-number ball1)) 870 (display " has a new velocity of ") 871 (display (ball-x-velocity ball1)) 872 (display ",") 873 (display (ball-y-velocity ball1)) 874 (display " starting at ") 875 (display (ball-collision-x-position ball1)) 876 (display ",") 877 (display (ball-collision-y-position ball1)) 878 (newline) 879 (display " Ball ") 880 (display (ball-number ball2)) 881 (display " has a new velocity of ") 882 (display (ball-x-velocity ball2)) 883 (display ",") 884 (display (ball-y-velocity ball2)) 885 (display " starting at ") 886 (display (ball-collision-x-position ball2)) 887 (display ",") 888 (display (ball-collision-y-position ball2)) 889 890 (recalculate-collisions ball1 global-event-queue) 891 (recalculate-collisions ball2 global-event-queue)) 892 893 894;;BUMPER-COLLISION-PROCEDURE calculates the new velocity of the given ball 895;;following its collision with the given bumper at the given time. Also, tells 896;;other balls about the new trajectory of the given ball so they can update 897;;their event queues. 898;;BALL = The ball 899;;BUMPER = The bumper 900;;COLLISION-TIME = The collision time 901;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball 902(define (bumper-collision-procedure ball bumper collision-time 903 global-event-queue) 904 (queue-remove ;Remove the earliest event associated 905 (ball-global-event-queue-record ;with the ball from the global event 906 ball)) ;queue 907 (let ((delta-x-bumper ;Compute the bumper's delta-x 908 (- (bumper-x2 bumper) 909 (bumper-x1 bumper))) 910 (delta-y-bumper ;delta-y 911 (- (bumper-y2 bumper) 912 (bumper-y1 bumper)))) 913 (let ((bumper-length ;length 914 (sqrt 915 (+ (square 916 delta-x-bumper) 917 (square 918 delta-y-bumper))))) 919 (let ((cos-theta ;and cosine and sine of its angle with 920 (/ delta-x-bumper ;respect to the positive x-axis 921 bumper-length)) 922 (sin-theta 923 (/ delta-y-bumper 924 bumper-length)) 925 (x-velocity ;Cache the ball's velocity in the x,y 926 (ball-x-velocity ball)) ;frame 927 (y-velocity 928 (ball-y-velocity ball))) 929 (let ((tang-velocity ;Calculate the ball's velocity in the 930 (+ (* x-velocity ;bumper frame 931 cos-theta) 932 (* y-velocity 933 sin-theta))) 934 (normal-velocity 935 (- (* y-velocity 936 cos-theta) 937 (* x-velocity 938 sin-theta)))) 939 940 941 (set-ball-collision-x-position! ;Store the collision position 942 ball 943 (+ (ball-collision-x-position 944 ball) 945 (* (- collision-time 946 (ball-collision-time 947 ball)) 948 (ball-x-velocity 949 ball)))) 950 (set-ball-collision-y-position! 951 ball 952 (+ (ball-collision-y-position 953 ball) 954 (* (- collision-time 955 (ball-collision-time 956 ball)) 957 (ball-y-velocity 958 ball)))) 959 (set-ball-x-velocity! ;Calculate the new velocity in the 960 ball ;x,y frame based on the fact that 961 (+ (* tang-velocity ;tangential velocity is unchanged and 962 cos-theta) ;the normal velocity is inverted when 963 (* normal-velocity ;the ball collides with the bumper 964 sin-theta))) 965 (set-ball-y-velocity! 966 ball 967 (- (* tang-velocity 968 sin-theta) 969 (* normal-velocity 970 cos-theta))) 971 (set-ball-collision-time! 972 ball 973 collision-time))))) 974 (newline) 975 (display "Ball ") 976 (display (ball-number ball)) 977 (display " collides with bumper ") 978 (display (bumper-number bumper)) 979 (display " at time ") 980 (display (ball-collision-time ball)) 981 (newline) 982 (display " Ball ") 983 (display (ball-number ball)) 984 (display " has a new velocity of ") 985 (display (ball-x-velocity ball)) 986 (display ",") 987 (display (ball-y-velocity ball)) 988 (display " starting at ") 989 (display (ball-collision-x-position ball)) 990 (display ",") 991 (display (ball-collision-y-position ball)) 992 993 (recalculate-collisions ball global-event-queue)) 994 995 996;;RECALCULATE-COLLISIONS removes all old collisions for the given ball from 997;;all other balls' event queues and calcultes new collisions for these balls 998;;and places them on the event queues. Also, updates the global event queue if 999;;the recalculation of the collision effects the earliest collision for any 1000;;other balls. 1001;;BALL = The ball whose collisions are being recalculated 1002;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball 1003(define (recalculate-collisions ball global-event-queue) 1004 (clear-queue (ball-event-queue ;Clear the queue of events for this 1005 ball)) ;ball as they have all changed 1006 (let ((event-queue ;Calculate all ball collision events 1007 (ball-event-queue ball))) ;with balls of lower number 1008 (let ((ball-vector 1009 (ball-ball-vector ball))) 1010 (do ((i (-1+ (ball-number ball)) 1011 (-1+ i))) 1012 ((negative? i)) 1013 (let ((ball2-queue-record 1014 (vector-ref 1015 ball-vector 1016 i))) 1017 (set-event-queue-record-collision-time! 1018 ball2-queue-record 1019 (ball-ball-collision-time 1020 ball 1021 (event-queue-record-object 1022 ball2-queue-record))) 1023 (queue-insert 1024 event-queue 1025 ball2-queue-record)))) 1026 (let ((bumper-vector ;Calculate all bumper collision events 1027 (ball-bumper-vector ball))) 1028 (do ((i (-1+ (vector-length 1029 bumper-vector)) 1030 (-1+ i))) 1031 ((negative? i)) 1032 (let ((bumper-queue-record 1033 (vector-ref 1034 bumper-vector 1035 i))) 1036 (set-event-queue-record-collision-time! 1037 bumper-queue-record 1038 (ball-bumper-collision-time 1039 ball 1040 (event-queue-record-object 1041 bumper-queue-record))) 1042 (queue-insert 1043 event-queue 1044 bumper-queue-record)))) 1045 1046 1047 (let ((global-queue-record ;Get the global event queue record 1048 (ball-global-event-queue-record ;for this ball 1049 ball))) 1050 (set-event-queue-record-collision-time! ;Set the new earliest event time 1051 global-queue-record ;for this ball 1052 (if (empty-queue? event-queue) 1053 '() 1054 (event-queue-record-collision-time 1055 (queue-smallest event-queue)))) 1056 (queue-insert ;Enqueue on the global event queue 1057 global-event-queue ;the earliest event between this ball 1058 global-queue-record))) ;and any ball of lower number or any 1059 ;bumper 1060 (for-each ;For each ball on the ball list: 1061 (lambda (ball2) 1062 (let ((ball2-event-queue 1063 (ball-event-queue ball2))) 1064 (let ((alter-global-event-queue? ;Set flag to update global event queue 1065 (and ;if the earliest event for ball2 was 1066 (not (empty-queue? ;with the deflected ball 1067 ball2-event-queue)) 1068 (eq? ball 1069 (event-queue-record-object 1070 (queue-smallest 1071 ball2-event-queue))))) 1072 (ball-event-queue-record ;Get the queue record for the deflected 1073 (vector-ref ;ball for this ball 1074 (ball-ball-vector 1075 ball2) 1076 (ball-number ball)))) 1077 (queue-remove ;Remove the queue record for the 1078 ball-event-queue-record) ;deflected ball 1079 (set-event-queue-record-collision-time! ;Recalculate the collision 1080 ball-event-queue-record ;time for this ball and the deflected 1081 (ball-ball-collision-time ;ball 1082 ball 1083 ball2)) 1084 (queue-insert ;Enqueue the new collision event 1085 ball2-event-queue 1086 ball-event-queue-record) 1087 (if (or alter-global-event-queue? ;If the earliest collision event for 1088 (eq? ball ;this ball has changed: 1089 (event-queue-record-object 1090 (queue-smallest 1091 ball2-event-queue)))) 1092 (let ((queue-record ;Remove the old event from the global 1093 (ball-global-event-queue-record ;event queue and replace it 1094 ball2))) ;with the new event 1095 (set-event-queue-record-collision-time! 1096 queue-record 1097 (event-queue-record-collision-time 1098 (queue-smallest 1099 ball2-event-queue))) 1100 (queue-remove 1101 queue-record) 1102 (queue-insert 1103 global-event-queue 1104 queue-record)))))) 1105 (ball-ball-list ball))) 1106 1107 1108;;SIMULATE performs the billiard ball simulation for the given ball list and 1109;;bumper list until the specified time. 1110;;BALL-LIST = A list of balls 1111;;BUMPER-LIST = A list of bumpers 1112;;END-TIME = The time at which the simulation is to terminate 1113(define (simulate ball-list bumper-list end-time) 1114 (let ((num-of-balls ;Cache the number of balls and bumpers 1115 (length ball-list)) 1116 (num-of-bumpers 1117 (length bumper-list)) 1118 (global-event-queue ;Build the global event queue 1119 (make-sorted-queue 1120 collision-time-<?))) 1121 (let ((complete-ball-vector ;Build a vector for the balls 1122 (make-vector 1123 num-of-balls))) 1124 (let loop ((ball-num 0) ;For each ball: 1125 (ball-list ball-list)) 1126 (if (not (null? ball-list)) 1127 (let ((ball (car ball-list))) 1128 (set-ball-number! ;Store the ball's number 1129 ball 1130 ball-num) 1131 (vector-set! ;Place it in the ball vector 1132 complete-ball-vector 1133 ball-num 1134 ball) 1135 (set-ball-ball-list! ;Save the list of balls with ball 1136 ball ;numbers greater than the current ball 1137 (cdr ball-list)) 1138 (display-ball-state 1139 ball) 1140 (loop 1141 (1+ ball-num) 1142 (cdr ball-list))))) 1143 (let loop ((bumper-num 0) ;For each bumper: 1144 (bumper-list 1145 bumper-list)) 1146 (if (not (null? bumper-list)) 1147 (sequence 1148 (set-bumper-number! ;Store the bumper's number 1149 (car bumper-list) 1150 bumper-num) 1151 (display-bumper-state 1152 (car bumper-list)) 1153 (loop 1154 (1+ bumper-num) 1155 (cdr bumper-list))))) 1156 1157 (do ((ball-num 0 (1+ ball-num))) ;For each ball: 1158 ((= ball-num num-of-balls)) 1159 (let* ((ball (vector-ref ;Cache a reference to the ball 1160 complete-ball-vector 1161 ball-num)) 1162 (ball-vector ;Build a vector for the queue records 1163 (make-vector ;of balls with smaller numbers than 1164 ball-num)) ;this ball 1165 (bumper-vector ;Build a vector for the queue records 1166 (make-vector ;of bumpers 1167 num-of-bumpers)) 1168 (event-queue ;Build an event queue for this ball 1169 (ball-event-queue 1170 ball))) 1171 (set-ball-ball-vector! ;Install the vector of ball queue 1172 ball ;records 1173 ball-vector) 1174 (do ((i 0 (1+ i))) ;For each ball of smaller number than 1175 ((= i ball-num)) ;the current ball: 1176 (let* ((ball2 ;Cache the ball 1177 (vector-ref 1178 complete-ball-vector 1179 i)) 1180 (queue-record ;Create a queue record for this ball 1181 (make-event-queue-record ;based on the collision time 1182 '() ;of the two balls 1183 '() 1184 ball2 1185 (ball-ball-collision-time 1186 ball 1187 ball2)))) 1188 (vector-set! ;Install the queue record in the ball 1189 ball-vector ;vector for this ball 1190 i 1191 queue-record) 1192 (queue-insert ;Insert the queue record into the event 1193 event-queue ;queue for this ball 1194 queue-record))) 1195 1196 (set-ball-bumper-vector! ;Install the vector of bumper queue 1197 ball ;records 1198 bumper-vector) 1199 (let loop ((bumper-num 0) 1200 (bumper-list 1201 bumper-list)) 1202 (if (not (null? bumper-list)) 1203 (let* ((bumper ;Cache the bumper 1204 (car 1205 bumper-list)) 1206 (queue-record ;Create a queue record for this bumper 1207 (make-event-queue-record ;based on the collision time 1208 '() ;of the current ball and this bumper 1209 '() 1210 bumper 1211 (ball-bumper-collision-time 1212 ball 1213 bumper)))) 1214 (vector-set! ;Install the queue record in the bumper 1215 bumper-vector ;vector for this ball 1216 bumper-num 1217 queue-record) 1218 (queue-insert ;Insert the queue record into the event 1219 event-queue ;queue for this ball 1220 queue-record) 1221 (loop 1222 (1+ bumper-num) 1223 (cdr bumper-list))))) 1224 (let ((queue-record ;Build a global event queue record for 1225 (make-event-queue-record ;the earliest event on this ball's 1226 '() ;event queue 1227 '() 1228 ball 1229 (if (empty-queue? 1230 event-queue) 1231 '() 1232 (event-queue-record-collision-time 1233 (queue-smallest 1234 event-queue)))))) 1235 (set-ball-global-event-queue-record! ;Store this queue record in 1236 ball ;the frame for this ball 1237 queue-record) 1238 (queue-insert ;Insert this queue record in the global 1239 global-event-queue ;event queue 1240 queue-record))))) 1241 (actually-simulate ;Now that all of the data structures 1242 global-event-queue ;have been built, actually start the 1243 end-time))) ;simulation 1244 1245 1246;;DISPLAY-BALL-STATE displays the ball number, mass, radius, position, and 1247;;velocity of the given ball 1248;;BALL = The ball whose state is to be displayed 1249(define (display-ball-state ball) 1250 (newline) 1251 (display "Ball ") 1252 (display (ball-number ball)) 1253 (display " has mass ") 1254 (display (ball-mass ball)) 1255 (display " and radius ") 1256 (display (ball-radius ball)) 1257 (newline) 1258 (display " Its position at time ") 1259 (display (ball-collision-time ball)) 1260 (display " was ") 1261 (display (ball-collision-x-position ball)) 1262 (display ",") 1263 (display (ball-collision-y-position ball)) 1264 (display " and its velocity is ") 1265 (display (ball-x-velocity ball)) 1266 (display ",") 1267 (display (ball-y-velocity ball))) 1268 1269;;DISPLAY-BUMPER-STATE displays the bumper number and position of the given 1270;;bumper 1271;;BUMPER = The bumper whose state is to be displayed 1272(define (display-bumper-state bumper) 1273 (newline) 1274 (display "Bumper ") 1275 (display (bumper-number bumper)) 1276 (display " extends from ") 1277 (display (bumper-x1 bumper)) 1278 (display ",") 1279 (display (bumper-y1 bumper)) 1280 (display " to ") 1281 (display (bumper-x2 bumper)) 1282 (display ",") 1283 (display (bumper-y2 bumper))) 1284 1285 1286;;ACTUALLY-SIMULATE performs the actual billiard ball simulation 1287;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball. 1288;; Contains a single event for each ball which is the 1289;; earliest collision it would have with a ball of a 1290;; smaller number or a bumper, if no other collisions took 1291;; place first. 1292;;END-TIME = The time at which the simulation should be terminated 1293(define (actually-simulate global-event-queue end-time) 1294 (letrec ((loop 1295 (lambda () 1296 (let* ((record ;Get the globally earliest event and 1297 (queue-smallest ;its time 1298 global-event-queue)) 1299 (collision-time 1300 (event-queue-record-collision-time 1301 record))) 1302 (if (not ;If this event happens before the 1303 (time-<? ;simulation termination time: 1304 end-time 1305 collision-time)) 1306 (let* ((ball ;Get the ball involved in the event, 1307 (event-queue-record-object 1308 record)) 1309 (ball-queue ;the queue of events for that ball, 1310 (ball-event-queue 1311 ball)) 1312 (other-object ;and the first object with which the 1313 (event-queue-record-object ;ball interacts 1314 (queue-smallest 1315 ball-queue)))) 1316 ((simulation-object-collision-procedure ;Process this 1317 other-object) ;globally earliest collision 1318 ball 1319 other-object 1320 collision-time 1321 global-event-queue) 1322 (loop))))))) ;Process the next interaction 1323 (loop))) 1324 1325 1326(require 'cscheme) 1327(set! autoload-notify? #f) 1328 1329 (simulate 1330 (list (make-ball 2 1 9 5 -1 -1) 1331 (make-ball 4 2 2 5 1 -1)) 1332 (list (make-bumper 0 0 0 10) 1333 (make-bumper 0 0 10 0) 1334 (make-bumper 0 10 10 10) 1335 (make-bumper 10 0 10 10)) 1336 100) 1337 1338(newline) 1339