home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / scheme / billiard < prev    next >
Encoding:
Text File  |  1991-09-25  |  45.0 KB  |  1,337 lines
  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.