Path: utzoo!attcan!uunet!allbery
From: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
Newsgroups: comp.sources.misc
Subject: v08i057: Elk (Extension Language Toolkit) part 09 of 14
Message-ID: <68225@uunet.UU.NET>
Date: 23 Sep 89 21:42:12 GMT
Sender: allbery@uunet.UU.NET
Reply-To: net@tub.UUCP (Oliver Laumann)
Lines: 1669
Approved: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 8, Issue 57
Submitted-by: net@tub.UUCP (Oliver Laumann)
Archive-name: elk/part09

[Let this be a lesson to submitters:  this was submitted as uuencoded,
compressed files.  I lost the source information while unpacking it; this
is the best approximation I could come up with.  ++bsa]

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of archive 9 (of 14)."
# Contents:  tst/billiard lib/xlib/examples/properties
#   lib/xlib/examples/track lib/xlib/examples/picture
#   lib/xlib/examples/useful lib/xlib/pixel.c
# Wrapped by net@tub on Sun Sep 17 17:32:32 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f tst/billiard -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"tst/billiard\"
else
echo shar: Extracting \"tst/billiard\" \(46118 characters\)
sed "s/^X//" >tst/billiard <<'END_OF_tst/billiard'
X;;;
X;;; BILLIARD.SCM: This file contains code for a very simple billiard ball
X;;;               simulator.  The simulation takes place in two dimensions.
X;;;               The balls are really disks in that their height is not taken
X;;;               into account.  All interactions are assumed to be
X;;;               frictionless so spin in irrelevant and not accounted for.
X;;;               (See section on limitations.)
X;;;
X;;; NOTES: A simulation is initiated by creating a number of balls and bumpers
X;;;        and and specifying a duration for the simulation.  For each ball,
X;;;        its mass, radius, initial position, and initial velocity must be
X;;;        specified.  For each bumper, the location of its two ends must be
X;;;        specified.  (Bumpers are assumed to have zero width.)
X;;;
X;;;        A sample run might be started as follows:
X;;;        (simulate
X;;;         (list (make-ball 2 1 9 5 -1 -1)
X;;;               (make-ball 4 2 2 5 1 -1))
X;;;         (list (make-bumper 0 0 0 10)
X;;;               (make-bumper 0 0 10 0)
X;;;               (make-bumper 0 10 10 10)
X;;;               (make-bumper 10 0 10 10))
X;;;         30)
X;;;
X;;;        It would create one billiard ball of mass 2 and radius 1 at position
X;;;        (9, 5) with initial velocity (-1, -1) and a second ball of mass 4
X;;;        and radius 2 at position (2, 5) with initial velocity (1, -1).  The
X;;;        table would be a 10X10 square.  (See diagram below)
X;;;
X;;;        +---------------------------+
X;;;        |                           |
X;;;        |                           |
X;;;        |    XXXX                   |
X;;;        |  XXXXXXXX             XX  |
X;;;        |XXXXXX4XXXXX         XXX2XX|
X;;;        |  XXXXXXXX            /XX  |
X;;;        |    XXXX \                 |
X;;;        |                           |
X;;;        |                           |
X;;;        +---------------------------+
X;;;
X;;; LIMITATIONS:  This simulator does not handle 3 body problems correctly.  If
X;;;               3 objects interact at one time, only the interactions of 2 of
X;;;               the bodies will be accounted for.  This can lead to strange
X;;;               effects like balls tunneling through walls and other balls.
X;;;               It is also possible to get balls bouncing inside of each
X;;;               other in this way. 
X;;;           
X
X
X;;MAKE-QUEUE-RECORD returns a queue record with the given next, previous, and
X;;value values
X;;NEXT = The next record pointer
X;;PREV = The previous record pointer
X;;REST = A list of values for any optional fields (this can be used for
X;;       creating structure inheritance)
X(define-macro (make-queue-record next prev . rest)
X  `(vector ,next ,prev ,@rest))
X	  
X;;QUEUE-RECORD-NEXT returns the next field of the given queue record
X;;QUEUE-RECORD = The queue record whose next field is to be returned
X(define-macro (queue-record-next queue-record)
X  `(vector-ref ,queue-record 0))
X
X;;SET-QUEUE-RECORD-NEXT! sets the next field of the given queue record
X;;QUEUE-RECORD = The queue record whose next field is to be set
X;;VALUE = The value to which the next field is to be set
X(define-macro (set-queue-record-next! queue-record value)
X  `(vector-set! ,queue-record 0 ,value))
X
X;;QUEUE-RECORD-PREV returns the prev field of the given queue record
X;;QUEUE-RECORD = The queue record whose prev field is to be returned
X(define-macro (queue-record-prev queue-record)
X  `(vector-ref ,queue-record 1))
X
X;;SET-QUEUE-RECORD-PREV! sets the prev field of the given queue record
X;;QUEUE-RECORD = The queue record whose prev field is to be set
X;;VALUE = The value to which the prev field is to be set
X(define-macro (set-queue-record-prev! queue-record value)
X  `(vector-set! ,queue-record 1 ,value))
X
X;;QUEUE-RECORD-LEN returns the length of a queue record which has no optional
X;;fields 
X(define-macro (queue-record-len) 2)
X
X;;QUEUE-HEAD returns a dummy record at the end of the queue with the record
X;;with the smallest key.
X;;QUEUE = the queue whose head record is to be returned
X(define-macro (queue-head queue)
X  `(vector-ref ,queue 0))
X
X;;QUEUE-TAIL returns a dummy record at the end of the queue with the record
X;;with the largest key.
X;;QUEUE = the queue whose tail record is to be returned
X(define-macro (queue-tail queue)
X  `(vector-ref ,queue 1))
X
X;;QUEUE-<? returns the less-than comparitor to be used in sorting
X;;records into the queue
X;;QUEUE = The queue whose comparitor is to be returned
X(define-macro (queue-<? queue)
X  `(vector-ref ,queue 2))
X
X
X;;MAKE-SORTED-QUEUE returns a queue object.  A queue header is a vector which
X;;contains a head pointer, a tail pointer, and a less-than comparitor. 
X;;QUEUE-<? = A predicate for sorting queue items
X(define (make-sorted-queue queue-<?)
X  (let ((queue
X	 (vector
X	  (make-queue-record		;The queue head record has no initial
X	   '()				;next, previous, or value values
X	   '())
X	  (make-queue-record		;The queue tail record has no intial
X	   '()				;next, previous, or value values
X	   '())
X	  queue-<?)))
X    (set-queue-record-next!
X     (queue-head queue)
X     (queue-tail queue))
X    (set-queue-record-prev!
X     (queue-tail queue)
X     (queue-head queue))
X    queue))
X
X;;MAKE-EVENT-QUEUE-RECORD returns an event queue record with the given next,
X;;previous, object, and collision-time values
X;;NEXT = The next record pointer
X;;PREV = The previous record pointer
X;;OBJECT = The simulation object associated with this record
X;;COLLISION-TIME = The collision time for this object
X(define-macro (make-event-queue-record next prev object collision-time)
X  `(make-queue-record ,next ,prev ,object ,collision-time))
X
X;;EVENT-QUEUE-RECORD-OBJECT returns the object associated with the given record
X;;QUEUE-RECORD = The queue record whose object field is to be returned
X(define-macro (event-queue-record-object queue-record)
X  `(vector-ref ,queue-record ,(queue-record-len)))
X
X;;EVENT-QUEUE-COLLISION-TIME returns the collision time associated with the
X;;given queue record
X;;QUEUE-RECORD = The queue record whose collision time field is to be returned
X(define-macro (event-queue-record-collision-time queue-record)
X  `(vector-ref ,queue-record ,(1+ (queue-record-len))))
X
X;;SET-EVENT-QUEUE-COLLISION-TIME! sets the collision time associated with the
X;;given queue record
X;;QUEUE-RECORD = The queue record whose collision time field is to be returned
X;;VALUE = The value to which it is to be set
X(define-macro (set-event-queue-record-collision-time! queue-record value)
X  `(vector-set! ,queue-record ,(1+ (queue-record-len)) ,value))
X
X
X;;QUEUE-INSERT inserts the given record in the given queue based on its value
X;;QUEUE = The queue into which the record is to be inserted
X;;QUEUE-RECORD = The record to be inserted in the queue
X(define (queue-insert queue queue-record)
X  (define (actual-insert insert-record next-record)
X    (if (or				;If the insert position has been found
X	 (eq? next-record		;or the end on the queue has been 
X	      (queue-tail queue))	;reached
X	 ((queue-<? queue)		
X	  insert-record
X	  next-record))
X	(sequence			;Link the insert record into the queue
X	  (set-queue-record-next!	;just prior to next-record
X	   (queue-record-prev
X	    next-record)
X	   insert-record)
X	  (set-queue-record-prev!
X	   insert-record
X	   (queue-record-prev
X	    next-record))
X	  (set-queue-record-next!
X	   insert-record
X	   next-record)
X	  (set-queue-record-prev!
X	   next-record
X	   insert-record))
X	(actual-insert			;Else, continue searching for the 
X	 insert-record			;insert position
X	 (queue-record-next
X	  next-record))))
X  (actual-insert			;Search for the correct position to 
X   queue-record				;perform the insert starting at the
X   (queue-record-next			;queue head and perform the insert 
X    (queue-head queue))))		;once this position has been found
X     
X;;QUEUE-REMOVE removes the given queue record from its queue
X;;QUEUE-RECORD = The record to be removed from the queue
X(define (queue-remove queue-record)
X  (set-queue-record-next!
X   (queue-record-prev
X    queue-record)
X   (queue-record-next
X    queue-record))
X  (set-queue-record-prev!
X   (queue-record-next
X    queue-record)
X   (queue-record-prev
X    queue-record)))
X
X;;QUEUE-SMALLEST returns the queue record with the smallest key on the given
X;;queue 
X;;QUEUE = The queue from which the smallest record is to be extracted
X(define (queue-smallest queue)
X  (queue-record-next
X   (queue-head queue)))
X
X
X;;CLEAR-QUEUE! clears the given queue by destructively removing all the records
X;;QUEUE = The queue to be cleared
X(define (clear-queue queue)
X  (set-queue-record-next!
X   (queue-head queue)
X   (queue-tail queue))
X  (set-queue-record-prev!
X   (queue-tail queue)
X   (queue-head queue)))
X
X;;EMPTY-QUEUE? returns true if the given queue is empty
X;;QUEUE = The queue to be tested for emptiness
X(define (empty-queue? queue)
X  (eq? (queue-record-next
X	(queue-head queue))
X       (queue-tail queue)))
X
X
X;;MAKE-SIMULATION-OBJECT returns a simulation object containing the given
X;;fields 
X;;COLLISION-PROCEDURE = A function for processing information about a potential
X;;                      collision between this object and some ball
X;;REST = A list of values for any optional fields (this can be used for
X;;       creating structure inheritance)
X(define-macro (make-simulation-object collision-procedure . rest)
X  `(vector ,collision-procedure ,@rest))
X
X;;SIMULATION-OBJECT-COLLLISION-PROCEDURE returns the collision procedure for
X;;the given simulation object
X;;OBJECT = The object whose collision procedure is to be returned
X(define-macro (simulation-object-collision-procedure object)
X  `(vector-ref ,object 0))
X
X;;SIMULATION-OBJECT-LEN returns the length of a simulation object which has no
X;;optional fields
X(define-macro (simulation-object-len) 1)
X
X
X;;ACTUAL-MAKE-BALL returns a ball object
X;;BALL-NUMBER = An index into the ball vector for this ball
X;;MASS = The ball's mass
X;;RADIUS = The ball's radius
X;;PX = The x-coordinate of the ball's initial position
X;;PY = The y-coordinate of the ball's initial position
X;;VX = The x-coordinate of the ball's initial velocity
X;;VY = The y-coordinate of the ball's initial velocity
X(define-macro (actual-make-ball ball-number mass radius px py vx vy)
X  `(make-simulation-object
X    ball-collision-procedure		;The collision procedure for a ball
X    ,ball-number
X    ,mass
X    ,radius
X    (make-sorted-queue			;The event queue
X     collision-time-<?)
X    0					;Time of last collision
X    ,px					;Position of last collision
X    ,py					; "
X    ,vx					;Velocity following last colliosion
X    ,vy					; "
X    '()					;No vector of queue records for ball's
X					;with smaller numbers  
X    '()					;No vector of queue records for bumpers
X    '()					;No list of balls with larger numbers
X    '()))				;No global event queue record, yet
X  
X(define (make-ball mass radius px py vx vy)
X  (actual-make-ball '() mass radius px py vx vy))
X
X;;BALL-NUMBER returns the index of the given ball
X;;BALL = The ball whose index is to be returned
X(define-macro (ball-number ball)
X  `(vector-ref ,ball ,(simulation-object-len)))
X
X;;SET-BALL-NUMBER! set the index of the given ball to the given value
X;;BALL = The ball whose index is to be set
X;;VALUE = The value to which it is to be set
X(define-macro (set-ball-number! ball value)
X  `(vector-set! ,ball ,(simulation-object-len) ,value))
X
X;;BALL-MASS returns the mass of the given ball
X;;BALL = The ball whose mass is to be returned
X(define-macro (ball-mass ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 1)))
X
X;;BALL-RADIUS returns the radius of the given ball
X;;BALL = The ball whose radius is to be returned
X(define-macro (ball-radius ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 2)))
X
X;;BALL-EVENT-QUEUE returns the sort queue of collision events for the given
X;;ball
X;;BALL = The ball whose event is to be returned
X(define-macro (ball-event-queue ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 3)))
X
X;;BALL-COLLISION-TIME returns the time of the last collision for the given ball
X;;BALL = The ball whose collision time is to be returned
X(define-macro (ball-collision-time ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 4)))
X
X
X;;SET-BALL-COLLISION-TIME! sets the time of the last collision for the given
X;;ball 
X;;BALL = The ball whose collision time is to be set
X;;VALUE = The value to which the ball's collision time is to be set
X(define-macro (set-ball-collision-time! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 4) ,value))
X
X;;BALL-COLLISION-X-POSITION returns the x-coordinate of the position  of the
X;;last collision for the given ball 
X;;BALL = The ball whose collision position is to be returned
X(define-macro (ball-collision-x-position ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 5)))
X
X;;SET-BALL-COLLISION-X-POSITION! sets the x-coordinate of the position of the
X;;last collision for the given ball 
X;;BALL = The ball whose collision position is to be set
X;;VALUE = The value to which the ball's collision position is to be set
X(define-macro (set-ball-collision-x-position! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 5) ,value))
X
X;;BALL-COLLISION-Y-POSITION returns the y-coordinate of the position  of the
X;;last collision for the given ball 
X;;BALL = The ball whose collision position is to be returned
X(define-macro (ball-collision-y-position ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 6)))
X
X;;SET-BALL-COLLISION-Y-POSITION! sets the y-coordinate of the position of the
X;;last collision for the given ball 
X;;BALL = The ball whose collision position is to be set
X;;VALUE = The value to which the ball's collision position is to be set
X(define-macro (set-ball-collision-y-position! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 6) ,value))
X
X;;BALL-X-VELOCITY returns the x-coordinate of the velocity of the given ball
X;;following its last collision
X;;BALL = The ball whose velocity is to be returned
X(define-macro (ball-x-velocity ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 7)))
X
X;;SET-BALL-X-VELOCITY! sets the x-coordinate of the velocity of the given ball
X;;BALL = The ball whose velocity is to be set
X;;VALUE = The value to which the ball's velocity is to be set
X(define-macro (set-ball-x-velocity! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 7) ,value))
X
X;;BALL-Y-VELOCITY returns the y-coordinate of the velocity  of the given ball
X;;following its last collision
X;;BALL = The ball whose velocity is to be returned
X(define-macro (ball-y-velocity ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 8)))
X
X;;SET-BALL-Y-VELOCITY! sets the y-coordinate of the velocity of the given ball
X;;BALL = The ball whose velocity is to be set
X;;VALUE = The value to which the ball's velocity is to be set
X(define-macro (set-ball-y-velocity! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 8) ,value))
X
X
X;;BALL-BALL-VECTOR returns the vector of queue records for balls with smaller
X;;ball numbers
X;;BALL = The ball whose ball vector is to be returned
X(define-macro (ball-ball-vector ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 9)))
X
X;;SET-BALL-BALL-VECTOR! sets the vector of queue records for balls with smaller
X;;ball numbers
X;;BALL = The ball whose ball vector is to be set
X;;VALUE = The vector to which the field is to be set
X(define-macro (set-ball-ball-vector! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 9) ,value))
X
X;;BALL-BUMPER-VECTOR returns the vector of queue records for bumpers
X;;BALL = The ball whose bumper vector is to be returned
X(define-macro (ball-bumper-vector ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 10)))
X
X;;SET-BALL-BUMPER-VECTOR! sets the vector of queue records for bumpers
X;;BALL = The ball whose bumper vector is to be set
X;;VALUE = The vector to which the field is to be set
X(define-macro (set-ball-bumper-vector! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 10) ,value))
X
X;;BALL-BALL-LIST returns a list of balls with larger ball numbers than the
X;;given ball
X;;BALL = The ball whose ball list is to be returned
X(define-macro (ball-ball-list ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 11)))
X
X;;SET-BALL-BALL-LIST! sets the list of balls with larger ball numbers than the
X;;given ball
X;;BALL = The ball whose ball list is to be set
X;;VALUE = The value to which the ball list is to be set
X(define-macro (set-ball-ball-list! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 11) ,value))
X
X;;BALL-GLOBAL-EVENT-QUEUE-RECORD returns the global event queue record for the
X;;given ball
X;;BALL = The ball whose global event queue record is to be returned
X(define-macro (ball-global-event-queue-record ball)
X  `(vector-ref ,ball ,(+ (simulation-object-len) 12)))
X
X;;SET-BALL-GLOBAL-EVENT-QUEUE-RECORD! set the global event queue record for the
X;;given ball to the given value
X;;BALL = The ball whose global event queue record is to be set
X;;VALUE = The value to which the global event queue record field is to be set
X(define-macro (set-ball-global-event-queue-record! ball value)
X  `(vector-set! ,ball ,(+ (simulation-object-len) 12) ,value))
X
X
X
X;;ACTUAL-MAKE-BUMPER returns a bumper object
X;;BUMPER-NUMBER = An index into the bumper vector for this bumper
X;;X1 = The x-coordiante of one end of the bumper
X;;Y1 = The y-coordiante of one end of the bumper
X;;X2 = The x-coordiante of the other end of the bumper
X;;Y2 = The y-coordiante of the other end of the bumper
X(define-macro (actual-make-bumper bumper-number x1 y1 x2 y2)
X  `(make-simulation-object
X    bumper-collision-procedure		;The collision procedure for a bumper
X    ,bumper-number
X    ,x1					;The bumper endpoints
X    ,y1
X    ,x2
X    ,y2))
X
X(define (make-bumper x1 y1 x2 y2)
X  (actual-make-bumper '() x1 y1 x2 y2))
X
X;;BUMPER-NUMBER returns the index of the given bumper
X;;BUMPER = The bumper whose index is to be returned
X(define-macro (bumper-number bumper)
X  `(vector-ref ,bumper ,(simulation-object-len)))
X
X;;SET-BUMPER-NUMBER! set the index of the given bumper to the given value
X;;BUMPER = The bumper whose index is to be set
X;;VALUE = The value to which it is to be set
X(define-macro (set-bumper-number! bumper value)
X  `(vector-set! ,bumper ,(simulation-object-len) ,value))
X
X;;BUMPER-X1 returns the x-coordinate of one end of the given bumber
X;;BUMPER = the bumper whose x-coordinate is to be returned
X(define-macro (bumper-x1 bumper)
X  `(vector-ref ,bumper ,(1+ (simulation-object-len))))
X
X;;SET-BUMPER-X1! sets the x-coordinate of one end of the given bumber
X;;BUMPER = the bumper whose x-coordinate is to be set
X;;VALUE = The value to which the bumpers x-coordinate is to be set
X(define-macro (set-bumper-x1! bumper value)
X  `(vector-set! ,bumper ,(1+ (simulation-object-len)) ,value))
X
X;;BUMPER-Y1 returns the y-coordinate of one end of the given bumber
X;;BUMPER = the bumper whose y-coordinate is to be returned
X(define-macro (bumper-y1 bumper)
X  `(vector-ref ,bumper ,(+ (simulation-object-len) 2)))
X
X;;SET-BUMPER-Y1! sets the y-coordinate of one end of the given bumber
X;;BUMPER = the bumper whose y-coordinate is to be set
X;;VALUE = The value to which the bumpers y-coordinate is to be set
X(define-macro (set-bumper-y1! bumper value)
X  `(vector-set! ,bumper ,(+ (simulation-object-len) 2) ,value))
X
X;;BUMPER-X2 returns the x-coordinate of the other end of the given bumber
X;;BUMPER = the bumper whose x-coordinate is to be returned
X(define-macro (bumper-x2 bumper)
X  `(vector-ref ,bumper ,(+ (simulation-object-len) 3)))
X
X;;SET-BUMPER-X2! sets the x-coordinate of the other end of the given bumber
X;;BUMPER = the bumper whose x-coordinate is to be set
X;;VALUE = The value to which the bumpers x-coordinate is to be set
X(define-macro (set-bumper-x2! bumper value)
X  `(vector-set! ,bumper ,(+ (simulation-object-len) 3) ,value))
X
X
X;;BUMPER-Y2 returns the y-coordinate of the other end of the given bumber
X;;BUMPER = the bumper whose y-coordinate is to be returned
X(define-macro (bumper-y2 bumper)
X  `(vector-ref ,bumper ,(+ (simulation-object-len) 4)))
X
X;;SET-BUMPER-Y2! sets the y-coordinate of the other end of the given bumber
X;;BUMPER = the bumper whose y-coordinate is to be set
X;;VALUE = The value to which the bumpers y-coordinate is to be set
X(define-macro (set-bumper-y2! bumper value)
X  `(vector-set! ,bumper ,(+ (simulation-object-len) 4) ,value))
X
X;;COLLISION-TIME-<? is a predicate which returns true if the first event queueu
X;;record represents a collision that will take place at an earlier time than
X;;the one for the second event queue record
X;;EVENT-QUEUE-RECORD1 = The first event queue record
X;;EVENT-QUEUE-RECORD2 = The second event queue record
X(define (collision-time-<? event-queue-record1 event-queue-record2)
X  (time-<?
X   (event-queue-record-collision-time
X    event-queue-record1)
X   (event-queue-record-collision-time
X    event-queue-record2)))
X
X;;TIME-<? is a predicate which returns true if the first time is smaller than
X;;the second.  '() represents a time infinitly large.
X(define (time-<? time1 time2)
X  (if (null? time1)
X      #f
X      (if (null? time2)
X	  #t
X	  (< time1 time2))))
X
X;;SQUARE returns the square of its argument
X(define (square x)
X  (* x x))
X
X
X;;BALL-BALL-COLLISION-TIME returns the time at which the two given balls would
X;;collide if neither interacted with any other objects, '() if never.  This
X;;calculation is performed by setting the distance between the balls to the sum
X;;of their radi and solving for the contact time.
X;;BALL1 = The first ball
X;;BALL2 = The second ball
X(define (ball-ball-collision-time ball1 ball2)
X  (let ((delta-x-velocity		;Cache the difference in the ball's
X	 ( - (ball-x-velocity ball2)	;velocities,
X	     (ball-x-velocity ball1)))
X	(delta-y-velocity
X	 ( - (ball-y-velocity ball2)	
X	     (ball-y-velocity ball1)))
X	(radius-sum			;the sum of their radi,
X	 (+ (ball-radius ball1)
X	    (ball-radius ball2)))
X	(alpha-x			;and common subexpressions in the time
X	 (-				;equation
X	  (- (ball-collision-x-position
X	      ball2)
X	     (ball-collision-x-position
X	      ball1))
X	  (-
X	   (* (ball-x-velocity ball2)	
X	      (ball-collision-time
X	       ball2))
X	   (* (ball-x-velocity ball1)	
X	      (ball-collision-time
X	       ball1)))))
X	(alpha-y
X	 (-
X	  (- (ball-collision-y-position
X	      ball2)
X	     (ball-collision-y-position
X	      ball1))
X	  (-
X	   (* (ball-y-velocity ball2)	
X	      (ball-collision-time
X	       ball2))
X	   (* (ball-y-velocity ball1)	
X	      (ball-collision-time
X	       ball1))))))
X    (let* ((delta-velocity-magnitude-squared
X	    (+ (square
X		delta-x-velocity)
X	       (square		
X		delta-y-velocity)))
X	   (discriminant
X	    (- (* (square radius-sum)
X		  delta-velocity-magnitude-squared)
X	       (square
X		(- (* delta-y-velocity
X		      alpha-x)
X		   (* delta-x-velocity
X		      alpha-y))))))
X
X
X      (if (or (negative? discriminant)	;If the balls don't colloide:
X	      (zero?
X	       delta-velocity-magnitude-squared))
X	  '()				;Return infinity
X	  (let ((time			;Else, calculate the collision time
X		 (/
X		  (- 0
X		     (+ (sqrt discriminant)
X			(+
X			 (* delta-x-velocity
X			    alpha-x)
X			 (* delta-y-velocity
X			    alpha-y))))
X		  (+ (square
X		      delta-x-velocity)
X		     (square
X		      delta-y-velocity)))))
X	    (if (and			;If the balls collide in the future:
X		 (time-<?
X		  (ball-collision-time
X		   ball1)
X		  time)
X		 (time-<?
X		  (ball-collision-time
X		   ball2)
X		  time))
X		time			;Return the collision time
X		'()))))))		;Else, return that they never collide
X
X;;BALL-BUMPER-COLLISION-TIME returns the time at which the given ball would
X;;collide with the given bumper if the ball didn't interacted with any other
X;;objects, '() if never.  This is done by first calculating the time at which
X;;the ball would collide with a bumper of infinite length and then checking if
X;;the collision position represents a portion of the actual bumper.
X;;BALL = The ball
X;;BUMPER = The bumper
X(define (ball-bumper-collision-time ball bumper)
X  (let ((delta-x-bumper			;Collision time with the bumper of 
X	 (- (bumper-x2 bumper)		;infinite extent is calculated by 
X	    (bumper-x1 bumper)))	;setting the distance between the ball
X	(delta-y-bumper			;and the bumper to be the radius of the
X	 (- (bumper-y2 bumper)		;ball and solving for the time.  The
X	    (bumper-y1 bumper))))	;distance is calculated by |aXb|/|a|,
X    (let ((bumper-length-squared	;where 'a' is the vector from one end
X	   (+ (square delta-x-bumper)	;of the bumper to the other and 'b' is
X	      (square delta-y-bumper)))	;the vector from the first end of the 
X	  (denominator			;bumper to the center of the ball
X	   (- (* (ball-y-velocity ball)
X		 delta-x-bumper)
X	      (* (ball-x-velocity ball)
X		 delta-y-bumper))))
X      (if (zero? denominator)		;If the ball's motion is parallel to
X					;the bumper:
X	  '()				;Return infinity
X	  (let ((delta-t		;Calculate the collision time
X		 (-
X		  (/
X		   (+
X		    (*
X		     (-	(ball-collision-x-position
X			 ball)
X			(bumper-x1 bumper))
X		     delta-y-bumper)
X		    (*
X		     (- (ball-collision-y-position
X			 ball)
X			(bumper-y1 bumper))
X		     delta-x-bumper))
X		   denominator)
X		  (/
X		   (* (ball-radius
X		       ball)
X		      (sqrt
X		       bumper-length-squared))
X		   (abs denominator)))))
X	    (if (not (positive?		;If the ball is moving away from the
X		      delta-t))		;bumper:
X		'()			;Return infinity
X
X
X		(let ((ball-x-contact	;Whether the ball contacts the actual
X		       (+ (ball-collision-x-position ;bumper of limited extent
X			   ball)	;will be determined by comparing |b.a|
X			  (* (ball-x-velocity ;with |a|^2
X			      ball)
X			     delta-t)))
X		      (ball-y-contact
X		       (+ (ball-collision-y-position
X			   ball)
X			  (* (ball-y-velocity
X			      ball)
X			     delta-t))))
X		  (let ((delta-x-ball
X			 (- ball-x-contact
X			    (bumper-x1
X			     bumper)))
X			(delta-y-ball
X			 (- ball-y-contact
X			    (bumper-y1
X			     bumper))))
X		    (let ((dot-product
X			   (+
X			    (* delta-x-ball
X			       delta-x-bumper)
X			    (* delta-y-ball
X			       delta-y-bumper))))
X		      (if (or		;If the ball misses the bumper on 
X			   (negative?	;either end:
X			    dot-product)
X			   (> dot-product
X			      bumper-length-squared))
X			  '()		;Return infinity
X			  (+ delta-t	;Else, return the contact time
X			     (ball-collision-time
X			      ball))))))))))))
X			       
X
X;;BALL-COLLISION-PROCEDURE calculates the new velocities of the given balls
X;;based on their collision at the given time.  Also, tells all other balls
X;;about the new trajectories of these balls so they can update their event
X;;queues 
X;;BALL1 = The first ball
X;;BALL2 = The second ball
X;;COLLISION-TIME = The collision time
X;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball
X(define (ball-collision-procedure ball1 ball2 collision-time
X				  global-event-queue)
X  (queue-remove				;Remove the earliest event associated
X   (ball-global-event-queue-record	;with each ball from the global event 
X    ball1))				;queue
X  (queue-remove
X   (ball-global-event-queue-record
X    ball2))
X  (let ((ball1-collision-x-position	;Calculate the positions of both balls
X	 (+ (ball-collision-x-position	;when they collide
X	     ball1)
X	    (* (ball-x-velocity
X		ball1)
X	       (- collision-time
X		  (ball-collision-time
X		   ball1)))))
X	(ball1-collision-y-position
X	 (+ (ball-collision-y-position
X	     ball1)
X	    (* (ball-y-velocity
X		ball1)
X	       (- collision-time
X		  (ball-collision-time
X		   ball1)))))
X	(ball2-collision-x-position
X	 (+ (ball-collision-x-position
X	     ball2)
X	    (* (ball-x-velocity
X		ball2)
X	       (- collision-time
X		  (ball-collision-time
X		   ball2)))))
X	(ball2-collision-y-position
X	 (+ (ball-collision-y-position
X	     ball2)
X	    (* (ball-y-velocity
X		ball2)
X	       (- collision-time
X		  (ball-collision-time
X		   ball2))))))
X    (let ((delta-x			;Calculate the displacements of the
X	   (- ball2-collision-x-position ;centers of the two balls
X	      ball1-collision-x-position))
X	  (delta-y
X	   (- ball2-collision-y-position
X	      ball1-collision-y-position)))
X
X
X      (let* ((denominator		;Calculate the angle of the line 
X	      (sqrt (+ (square		;joining the centers at the collision 
X			delta-x)	;time with the x-axis  (this line is
X		       (square		;the normal to the balls at the
X			delta-y))))	;collision point)
X	     (cos-theta			
X	      (/ delta-x denominator))
X	     (sin-theta
X	      (/ delta-y denominator)))
X	  (let ((ball1-old-normal-velocity ;Convert the velocities of the balls
X		 (+ (* (ball-x-velocity	;into the coordinate system defined by 
X			ball1)		;the normal and tangential lines at 
X		       cos-theta)	;the collision point
X		    (* (ball-y-velocity
X			ball1)
X		       sin-theta)))
X		(ball1-tang-velocity
X		 (- (* (ball-y-velocity
X			ball1)
X		       cos-theta)
X		    (* (ball-x-velocity
X			ball1)
X		       sin-theta)))
X		(ball2-old-normal-velocity
X		 (+ (* (ball-x-velocity
X			ball2)
X		       cos-theta)
X		    (* (ball-y-velocity
X			ball2)
X		       sin-theta)))
X		(ball2-tang-velocity
X		 (- (* (ball-y-velocity
X			ball2)
X		       cos-theta)
X		    (* (ball-x-velocity
X			ball2)
X		       sin-theta)))
X		(mass1 (ball-mass
X			ball1))
X		(mass2 (ball-mass
X			ball2)))
X	    (let ((ball1-new-normal-velocity ;Calculate the new velocities
X		   (/			;following the collision (the 
X		    (+			;tangential velocities are unchanged
X		     (*			;because the balls are assumed to be
X		      (* 2		;frictionless)
X			 mass2)
X		      ball2-old-normal-velocity)
X		     (*
X		      (- mass1 mass2)
X		      ball1-old-normal-velocity))
X		    (+ mass1 mass2)))
X
X
X		  (ball2-new-normal-velocity
X		   (/
X		    (+
X		     (*
X		      (* 2
X			 mass1)
X		      ball1-old-normal-velocity)
X		     (*
X		      (- mass2 mass1)
X		      ball2-old-normal-velocity))
X		    (+ mass1 mass2))))
X	      (set-ball-x-velocity!	;Store data about the collision in the
X	       ball1			;structure for each ball after 
X	       (- (* ball1-new-normal-velocity ;converting the information back
X		     cos-theta)		;to the x,y frame
X		  (* ball1-tang-velocity
X		     sin-theta)))
X	      (set-ball-y-velocity!
X	       ball1
X	       (+ (* ball1-new-normal-velocity
X		     sin-theta)
X		  (* ball1-tang-velocity
X		     cos-theta)))
X	      (set-ball-x-velocity!
X	       ball2
X	       (- (* ball2-new-normal-velocity
X		     cos-theta)
X		  (* ball2-tang-velocity
X		     sin-theta)))
X	      (set-ball-y-velocity!
X	       ball2
X	       (+ (* ball2-new-normal-velocity
X		     sin-theta)
X		  (* ball2-tang-velocity
X		     cos-theta)))
X	      (set-ball-collision-time!
X	       ball1
X	       collision-time)
X	      (set-ball-collision-time!
X	       ball2
X	       collision-time)
X	      (set-ball-collision-x-position!
X	       ball1
X	       ball1-collision-x-position)
X	      (set-ball-collision-y-position!
X	       ball1
X	       ball1-collision-y-position)
X	      (set-ball-collision-x-position!
X	       ball2
X	       ball2-collision-x-position)
X	      (set-ball-collision-y-position!
X	       ball2
X	       ball2-collision-y-position))))))
X
X
X  (newline)
X  (display "Ball ")
X  (display (ball-number ball1))
X  (display " collides with ball ")
X  (display (ball-number ball2))
X  (display " at time ")
X  (display (ball-collision-time ball1))
X  (newline)
X  (display "   Ball ")
X  (display (ball-number ball1))
X  (display " has a new velocity of ")
X  (display (ball-x-velocity ball1))
X  (display ",")
X  (display (ball-y-velocity ball1))
X  (display " starting at ")
X  (display (ball-collision-x-position ball1))
X  (display ",")
X  (display (ball-collision-y-position ball1))
X  (newline)
X  (display "   Ball ")
X  (display (ball-number ball2))
X  (display " has a new velocity of ")
X  (display (ball-x-velocity ball2))
X  (display ",")
X  (display (ball-y-velocity ball2))
X  (display " starting at ")
X  (display (ball-collision-x-position ball2))
X  (display ",")
X  (display (ball-collision-y-position ball2))
X
X  (recalculate-collisions ball1 global-event-queue)
X  (recalculate-collisions ball2 global-event-queue))
X
X
X;;BUMPER-COLLISION-PROCEDURE calculates the new velocity of the given ball
X;;following its collision with the given bumper at the given time.  Also, tells
X;;other balls about the new trajectory of the given ball so they can update
X;;their event queues.
X;;BALL = The ball
X;;BUMPER = The bumper
X;;COLLISION-TIME = The collision time
X;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball
X(define (bumper-collision-procedure ball bumper collision-time
X				    global-event-queue)
X  (queue-remove				;Remove the earliest event associated
X   (ball-global-event-queue-record	;with the ball from the global event 
X    ball))				;queue
X  (let ((delta-x-bumper			;Compute the bumper's delta-x
X	 (- (bumper-x2 bumper)
X	    (bumper-x1 bumper)))
X	(delta-y-bumper			;delta-y
X	 (- (bumper-y2 bumper)
X	    (bumper-y1 bumper))))
X    (let ((bumper-length		;length
X	   (sqrt
X	    (+ (square
X		delta-x-bumper)
X	       (square
X		delta-y-bumper)))))
X      (let ((cos-theta			;and cosine and sine of its angle with
X	     (/ delta-x-bumper		;respect to the positive x-axis
X		bumper-length))
X	    (sin-theta
X	     (/ delta-y-bumper
X		bumper-length))
X	    (x-velocity			;Cache the ball's velocity in the x,y
X	     (ball-x-velocity ball))	;frame
X	    (y-velocity
X	     (ball-y-velocity ball)))
X	(let ((tang-velocity		;Calculate the ball's velocity in the
X	       (+ (* x-velocity		;bumper frame
X		     cos-theta)
X		  (* y-velocity
X		     sin-theta)))
X	      (normal-velocity
X	       (- (* y-velocity
X		     cos-theta)
X		  (* x-velocity
X		     sin-theta))))
X
X
X	  (set-ball-collision-x-position! ;Store the collision position
X	   ball
X	   (+ (ball-collision-x-position
X	       ball)
X	      (* (- collision-time
X		    (ball-collision-time
X		     ball))
X		 (ball-x-velocity
X		  ball))))
X	  (set-ball-collision-y-position!
X	   ball
X	   (+ (ball-collision-y-position
X	       ball)
X	      (* (- collision-time
X		    (ball-collision-time
X		     ball))
X		 (ball-y-velocity
X		  ball))))
X	  (set-ball-x-velocity!		;Calculate the new velocity in the 
X	   ball				;x,y frame based on the fact that 
X	   (+ (* tang-velocity		;tangential velocity is unchanged and
X		 cos-theta)		;the normal velocity is inverted when
X	      (* normal-velocity	;the ball collides with the bumper
X		 sin-theta)))
X	  (set-ball-y-velocity!
X	   ball
X	   (- (* tang-velocity
X		 sin-theta)
X	      (* normal-velocity
X		 cos-theta)))
X	  (set-ball-collision-time!
X	   ball
X	   collision-time)))))
X  (newline)
X  (display "Ball ")
X  (display (ball-number ball))
X  (display " collides with bumper ")
X  (display (bumper-number bumper))
X  (display " at time ")
X  (display (ball-collision-time ball))
X  (newline)
X  (display "   Ball ")
X  (display (ball-number ball))
X  (display " has a new velocity of ")
X  (display (ball-x-velocity ball))
X  (display ",")
X  (display (ball-y-velocity ball))
X  (display " starting at ")
X  (display (ball-collision-x-position ball))
X  (display ",")
X  (display (ball-collision-y-position ball))
X
X  (recalculate-collisions ball global-event-queue))
X
X
X;;RECALCULATE-COLLISIONS removes all old collisions for the given ball from
X;;all other balls' event queues and calcultes new collisions for these balls
X;;and places them on the event queues.  Also, updates the global event queue if
X;;the recalculation of the collision effects the earliest collision for any
X;;other balls.
X;;BALL = The ball whose collisions are being recalculated
X;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball
X(define (recalculate-collisions ball global-event-queue)
X  (clear-queue (ball-event-queue	;Clear the queue of events for this 
X		ball))			;ball as they have all changed
X  (let ((event-queue			;Calculate all ball collision events
X	 (ball-event-queue ball)))	;with balls of lower number
X    (let ((ball-vector
X	   (ball-ball-vector ball)))
X      (do ((i (-1+ (ball-number ball))
X	      (-1+ i)))
X	  ((negative? i))
X	(let ((ball2-queue-record
X	       (vector-ref
X		ball-vector
X		i)))
X	  (set-event-queue-record-collision-time!
X	   ball2-queue-record
X	   (ball-ball-collision-time
X	    ball
X	    (event-queue-record-object
X	     ball2-queue-record)))
X	  (queue-insert
X	   event-queue
X	   ball2-queue-record))))
X    (let ((bumper-vector		;Calculate all bumper collision events
X	   (ball-bumper-vector ball)))
X      (do ((i (-1+ (vector-length
X		    bumper-vector))
X	      (-1+ i)))
X	  ((negative? i))
X	(let ((bumper-queue-record
X	       (vector-ref
X		bumper-vector
X		i)))
X	  (set-event-queue-record-collision-time!
X	   bumper-queue-record
X	   (ball-bumper-collision-time
X	    ball
X	    (event-queue-record-object
X	     bumper-queue-record)))
X	  (queue-insert
X	   event-queue
X	   bumper-queue-record))))
X
X
X    (let ((global-queue-record		;Get the global event queue record 
X	   (ball-global-event-queue-record ;for this ball
X	    ball)))
X      (set-event-queue-record-collision-time! ;Set the new earliest event time
X       global-queue-record		;for this ball
X       (if (empty-queue? event-queue)
X	   '()
X	   (event-queue-record-collision-time
X	    (queue-smallest event-queue))))
X      (queue-insert			;Enqueue on the global event queue
X       global-event-queue		;the earliest event between this ball
X       global-queue-record)))		;and any ball of lower number or any
X					;bumper
X  (for-each				;For each ball on the ball list:
X   (lambda (ball2)
X     (let ((ball2-event-queue
X	    (ball-event-queue ball2)))
X       (let ((alter-global-event-queue?	;Set flag to update global event queue 
X	      (and			;if the earliest event for ball2 was
X	       (not (empty-queue?	;with the deflected ball
X		     ball2-event-queue))
X	       (eq? ball
X		    (event-queue-record-object
X		     (queue-smallest
X		      ball2-event-queue)))))
X	     (ball-event-queue-record	;Get the queue record for the deflected
X	      (vector-ref		;ball for this ball
X	       (ball-ball-vector
X		ball2)
X	       (ball-number ball))))
X	 (queue-remove			;Remove the queue record for the 
X	  ball-event-queue-record)	;deflected ball
X	 (set-event-queue-record-collision-time! ;Recalculate the collision 
X	  ball-event-queue-record	;time for this ball and the deflected
X	  (ball-ball-collision-time	;ball
X	   ball
X	   ball2))
X	 (queue-insert			;Enqueue the new collision event
X	  ball2-event-queue
X	  ball-event-queue-record)
X	 (if (or alter-global-event-queue? ;If the earliest collision event for
X		 (eq? ball		;this ball has changed:
X		      (event-queue-record-object
X		       (queue-smallest
X			ball2-event-queue))))
X	     (let ((queue-record	;Remove the old event from the global
X		    (ball-global-event-queue-record ;event queue and replace it
X		     ball2)))		;with the new event
X	       (set-event-queue-record-collision-time! 
X		queue-record
X		(event-queue-record-collision-time
X		 (queue-smallest
X		  ball2-event-queue)))
X	       (queue-remove
X		queue-record)
X	       (queue-insert
X		global-event-queue
X		queue-record))))))
X   (ball-ball-list ball)))
X	   
X
X;;SIMULATE performs the billiard ball simulation for the given ball list and
X;;bumper list until the specified time.  
X;;BALL-LIST = A list of balls
X;;BUMPER-LIST = A list of bumpers
X;;END-TIME = The time at which the simulation is to terminate
X(define (simulate ball-list bumper-list end-time)
X  (let ((num-of-balls			;Cache the number of balls and bumpers
X	 (length ball-list))
X	(num-of-bumpers
X	 (length bumper-list))
X	(global-event-queue		;Build the global event queue
X	 (make-sorted-queue
X	  collision-time-<?)))
X    (let ((complete-ball-vector		;Build a vector for the balls
X	   (make-vector
X	    num-of-balls)))
X      (let loop ((ball-num 0)		;For each ball:
X		 (ball-list ball-list))
X	(if (not (null? ball-list))
X	    (let ((ball (car ball-list)))
X	      (set-ball-number!		;Store the ball's number
X	       ball
X	       ball-num)
X	      (vector-set!		;Place it in the ball vector
X	       complete-ball-vector
X	       ball-num
X	       ball)
X	      (set-ball-ball-list!	;Save the list of balls with ball
X	       ball			;numbers greater than the current ball
X	       (cdr ball-list))
X	      (display-ball-state
X	       ball)
X	      (loop
X	       (1+ ball-num)
X	       (cdr ball-list)))))
X      (let loop ((bumper-num 0)		;For each bumper:
X		 (bumper-list
X		  bumper-list))
X	(if (not (null? bumper-list))
X	    (sequence
X	      (set-bumper-number!	;Store the bumper's number
X	       (car bumper-list)
X	       bumper-num)
X	      (display-bumper-state
X	       (car bumper-list))
X	      (loop
X	       (1+ bumper-num)
X	       (cdr bumper-list)))))
X
X      (do ((ball-num 0 (1+ ball-num)))	;For each ball:
X	  ((= ball-num num-of-balls))
X	(let* ((ball (vector-ref	;Cache a reference to the ball
X		      complete-ball-vector
X		      ball-num))
X	       (ball-vector		;Build a vector for the queue records 
X		(make-vector		;of balls with smaller numbers than 
X		 ball-num))		;this ball
X	       (bumper-vector		;Build a vector for the queue records
X		(make-vector		;of bumpers
X		 num-of-bumpers))
X	       (event-queue		;Build an event queue for this ball
X		(ball-event-queue
X		 ball)))
X	  (set-ball-ball-vector!	;Install the vector of ball queue 
X	   ball				;records
X	   ball-vector)
X	  (do ((i 0 (1+ i)))		;For each ball of smaller number than 
X		  ((= i ball-num))	;the current ball:
X		(let* ((ball2		;Cache the ball
X			(vector-ref
X			 complete-ball-vector
X			 i))
X		       (queue-record	;Create a queue record for this ball
X			(make-event-queue-record ;based on the collision time 
X			 '()		;of the two balls
X			 '()
X			 ball2
X			 (ball-ball-collision-time
X			  ball
X			  ball2))))
X		  (vector-set!		;Install the queue record in the ball
X		   ball-vector		;vector for this ball
X		   i
X		   queue-record)
X		  (queue-insert		;Insert the queue record into the event
X		   event-queue		;queue for this ball
X		   queue-record)))
X
X	  (set-ball-bumper-vector!	;Install the vector of bumper queue
X	   ball				;records
X	   bumper-vector)
X	  (let loop ((bumper-num 0)
X		     (bumper-list
X		      bumper-list))
X	    (if (not (null? bumper-list))
X		(let* ((bumper		;Cache the bumper
X			(car
X			 bumper-list))
X		       (queue-record	;Create a queue record for this bumper
X			(make-event-queue-record ;based on the collision time 
X			 '()		;of the current ball and this bumper
X			 '()
X			 bumper
X			 (ball-bumper-collision-time
X			  ball
X			  bumper))))
X		  (vector-set!		;Install the queue record in the bumper
X		   bumper-vector	;vector for this ball
X		   bumper-num
X		   queue-record)
X		  (queue-insert		;Insert the queue record into the event
X		   event-queue		;queue for this ball
X		   queue-record)
X		  (loop
X		   (1+ bumper-num)
X		   (cdr bumper-list)))))
X	  (let ((queue-record		;Build a global event queue record for
X		 (make-event-queue-record ;the earliest event on this ball's 
X		  '()			;event queue
X		  '()
X		  ball
X		  (if (empty-queue?
X		       event-queue)
X		      '()
X		      (event-queue-record-collision-time
X		       (queue-smallest
X			event-queue))))))
X	    (set-ball-global-event-queue-record! ;Store this queue record in 
X	     ball			;the frame for this ball
X	     queue-record)
X	    (queue-insert		;Insert this queue record in the global
X	     global-event-queue		;event queue
X	     queue-record)))))
X    (actually-simulate			;Now that all of the data structures
X     global-event-queue			;have been built, actually start the 
X     end-time)))			;simulation
X	      
X
X;;DISPLAY-BALL-STATE displays the ball number, mass, radius, position, and
X;;velocity of the given ball
X;;BALL = The ball whose state is to be displayed
X(define (display-ball-state ball)
X  (newline)
X  (display "Ball ")
X  (display (ball-number ball))
X  (display " has mass ")
X  (display (ball-mass ball))
X  (display " and radius ")
X  (display (ball-radius ball))
X  (newline)
X  (display "   Its position at time ")
X  (display (ball-collision-time ball))
X  (display " was ")
X  (display (ball-collision-x-position ball))
X  (display ",")
X  (display (ball-collision-y-position ball))
X  (display " and its velocity is ")
X  (display (ball-x-velocity ball))
X  (display ",")
X  (display (ball-y-velocity ball)))
X
X;;DISPLAY-BUMPER-STATE displays the bumper number and position of the given
X;;bumper 
X;;BUMPER = The bumper whose state is to be displayed
X(define (display-bumper-state bumper)
X  (newline)
X  (display "Bumper ")
X  (display (bumper-number bumper))
X  (display " extends from ")
X  (display (bumper-x1 bumper))
X  (display ",")
X  (display (bumper-y1 bumper))
X  (display " to ")
X  (display (bumper-x2 bumper))
X  (display ",")
X  (display (bumper-y2 bumper)))
X
X
X;;ACTUALLY-SIMULATE performs the actual billiard ball simulation
X;;GLOBAL-EVENT-QUEUE = The global queue of earliest events for each ball.
X;;                     Contains a single event for each ball which is the
X;;                     earliest collision it would have with a ball of a
X;;                     smaller number or a bumper, if no other collisions took
X;;                     place first.
X;;END-TIME = The time at which the simulation should be terminated
X(define (actually-simulate global-event-queue end-time)
X  (letrec ((loop			
X	    (lambda ()
X	      (let* ((record		;Get the globally earliest event and
X		      (queue-smallest	;its time
X		       global-event-queue))
X		     (collision-time
X		      (event-queue-record-collision-time
X		       record)))
X		(if (not		;If this event happens before the
X		     (time-<?		;simulation termination time:
X		      end-time
X		      collision-time))
X		    (let* ((ball	;Get the ball involved in the event,
X			    (event-queue-record-object
X			     record))
X			   (ball-queue	;the queue of events for that ball,
X			    (ball-event-queue
X			     ball))
X			   (other-object ;and the first object with which the 
X			    (event-queue-record-object ;ball interacts
X			     (queue-smallest
X			      ball-queue))))
X		      ((simulation-object-collision-procedure ;Process this
X			other-object)	;globally earliest collision
X		       ball
X		       other-object
X		       collision-time
X		       global-event-queue)
X		      (loop)))))))	;Process the next interaction
X    (loop)))
X
X
X(require 'cscheme)
X(set! autoload-notify? #f)
X
X        (simulate
X         (list (make-ball 2 1 9 5 -1 -1)
X               (make-ball 4 2 2 5 1 -1))
X         (list (make-bumper 0 0 0 10)
X               (make-bumper 0 0 10 0)
X               (make-bumper 0 10 10 10)
X               (make-bumper 10 0 10 10))
X         100)
END_OF_tst/billiard
if test 46118 -ne `wc -c <tst/billiard`; then
    echo shar: \"tst/billiard\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xlib/examples/properties -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"lib/xlib/examples/properties\"
else
echo shar: Extracting \"lib/xlib/examples/properties\" \(969 characters\)
sed "s/^X//" >lib/xlib/examples/properties <<'END_OF_lib/xlib/examples/properties'
X;;; -*-Scheme-*-
X;;;
X;;; Display all properties of all windows (with name, type, format,
X;;; and data).
X
X(require 'xlib)
X
X(define (properties)
X  (let ((dpy (open-display)))
X    (unwind-protect
X     (let* ((w (car (query-tree (display-root-window dpy))))
X	    (l (map (lambda (win) (cons win (list-properties win)))
X		    (cons (display-root-window dpy) (vector->list w))))
X	    (tab (lambda (obj n)
X		   (let* ((s (format #f "~s" obj))
X			  (n (- n (string-length s))))
X		     (display s)
X		     (if (positive? n)
X			 (do ((i 0 (1+ i))) ((= i n)) (display #\space)))))))
X       (for-each
X	(lambda (w)
X	  (format #t "Window ~s:~%" (car w))
X	  (for-each
X	   (lambda (p)
X	     (tab (atom-name dpy p) 20)
X	     (display "= ")
X	     (let ((p (get-property (car w) p #f 0 20 #f)))
X	       (tab (atom-name dpy (car p)) 18)
X	       (tab (cadr p) 3)
X	       (format #t "~s~%" (caddr p))))
X	   (vector->list (cdr w)))
X	  (newline))
X	l))
X     (close-display dpy))))
X
X(properties)
END_OF_lib/xlib/examples/properties
if test 969 -ne `wc -c <lib/xlib/examples/properties`; then
    echo shar: \"lib/xlib/examples/properties\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xlib/examples/track -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"lib/xlib/examples/track\"
else
echo shar: Extracting \"lib/xlib/examples/track\" \(1062 characters\)
sed "s/^X//" >lib/xlib/examples/track <<'END_OF_lib/xlib/examples/track'
X;;; -*-Scheme-*-
X
X(require 'xlib)
X
X(define (track)
X  (let* ((dpy (open-display))
X	 (root (display-root-window dpy))
X	 (gc (make-gcontext (window root)
X			    (function 'xor)
X			    (foreground (black-pixel dpy))
X			    (subwindow-mode 'include-inferiors)))
X	 (lx 0) (ly 0) (lw 0) (lh 0)
X	 (move-outline
X	  (lambda (x y w h)
X	    (if (not (and (= x lx) (= y ly) (= w lw) (= h lh)))
X		(begin
X		  (draw-rectangle root gc lx ly lw lh)
X		  (draw-rectangle root gc x y w h)
X		  (set! lx x) (set! ly y)
X		  (set! lw w) (set! lh h))))))
X    (unwind-protect
X     (case (grab-pointer root #f '(pointer-motion button-press)
X			 #f #f 'none 'none 'now)
X       (success
X	(with-server-grabbed dpy
X	  (draw-rectangle root gc lx ly lw lh)
X	  (display-flush-output dpy)
X	  (handle-events dpy
X	    (motion-notify
X	     (lambda (event root win subwin time x y . rest)
X	       (move-outline x y 300 300) #f))
X	    (else (lambda args #t)))))
X       (else
X	(format #t "Not grabbed!~%")))
X     (begin
X       (draw-rectangle root gc lx ly lw lh)
X       (close-display dpy)))))
X
X(track)
END_OF_lib/xlib/examples/track
if test 1062 -ne `wc -c <lib/xlib/examples/track`; then
    echo shar: \"lib/xlib/examples/track\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xlib/examples/picture -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"lib/xlib/examples/picture\"
else
echo shar: Extracting \"lib/xlib/examples/picture\" \(2425 characters\)
sed "s/^X//" >lib/xlib/examples/picture <<'END_OF_lib/xlib/examples/picture'
X;;; -*-Scheme-*-
X
X;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
X
X;;; CLX - Point Graphing demo program
X
X;;; Copyright (C) 1988 Michael O. Newton (newton@csvax.caltech.edu)
X
X;;; Permission is granted to any individual or institution to use, copy,
X;;; modify, and distribute this software, provided that this complete
X;;; copyright and permission notice is maintained, intact, in all copies and
X;;; supporting documentation.
X
X;;; The author provides this software "as is" without express or
X;;; implied warranty.
X
X;;; This routine plots the recurrance
X;;;      x <- y(1+sin(0.7x)) - 1.2(|x|)^.5
X;;;      y <- .21 - x
X;;; As described in a ?? 1983 issue of the Mathematical Intelligencer
X;;; It has ONLY been tested under X.V11R2 on a Sun3 running KCL
X
X(require 'xlib)
X
X(define (picture point-count)
X  (let* ((dpy (open-display))
X	 (width 600)
X	 (height 600)
X	 (black (black-pixel dpy))
X	 (white (white-pixel dpy))
X	 (root (display-root-window dpy))
X	 (win (make-window (parent root) (background-pixel white)
X			   (event-mask '(exposure button-press))
X			   (width width) (height height)))
X	 (gc (make-gcontext (window win)
X			    (background white) (foreground black))))
X    (map-window win)
X    (unwind-protect
X     (handle-events dpy
X       (expose
X	(lambda ignore
X	  (clear-window win)
X	  (draw-points win gc point-count 0.0 0.0 (* width 0.5) (* height 0.5))
X	  (draw-poly-text win gc 10 10 (translate "Click a button to exit")
X			  '1-byte)
X	  #f))
X       (else (lambda ignore #t)))
X     (close-display dpy))))
X
X;;; Draw points.  These should maybe be put into a an array so that they do
X;;; not have to be recomputed on exposure.  X assumes points are in the range
X;;; of width x height, with 0,0 being upper left and 0,H being lower left.
X;;;      x <- y(1+sin(0.7x)) - 1.2(|x|)^.5
X;;;      y <- .21 - x
X;;; hw and hh are half-width and half-height of screen
X
X(define (draw-points win gc count x y hw hh)
X  (if (zero? (modulo count 100))
X      (display-flush-output (window-display win)))
X  (if (not (zero? count))
X      (let ((xf (floor (* (+ 1.2 x) hw ))) ; These lines center the picture
X	    (yf (floor (* (+ 0.5 y) hh ))))
X	(draw-point win gc xf yf)
X	(draw-points win gc (1- count)
X		     (- (* y (1+ (sin (* 0.7 x)))) (* 1.2 (sqrt (abs x))))
X		     (- 0.21 x)
X		     hw hh))))
X
X(define (translate string)
X  (list->vector (map char->integer (string->list string))))
X
X(picture 10000)
END_OF_lib/xlib/examples/picture
if test 2425 -ne `wc -c <lib/xlib/examples/picture`; then
    echo shar: \"lib/xlib/examples/picture\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xlib/examples/useful -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"lib/xlib/examples/useful\"
else
echo shar: Extracting \"lib/xlib/examples/useful\" \(567 characters\)
sed "s/^X//" >lib/xlib/examples/useful <<'END_OF_lib/xlib/examples/useful'
X;;; -*-Scheme-*-
X
X(require 'xlib)
X
X(define dpy
X  (open-display))
X
X(define (f)
X  (display-wait-output dpy #t))
X
X(define root
X  (display-root-window dpy))
X
X(define cmap
X  (display-colormap dpy))
X
X(define white (white-pixel dpy))
X(define black (black-pixel dpy))
X
X(define rgb-white (query-color cmap white))
X(define rgb-black (query-color cmap black))
X
X(define win
X  (make-window (parent root)
X	       (width 300) (height 300)
X	       (background-pixel white)))
X
X(define gc (make-gcontext
X	    (window win)
X	    (background white) (foreground black)))
X
X(map-window win)
END_OF_lib/xlib/examples/useful
if test 567 -ne `wc -c <lib/xlib/examples/useful`; then
    echo shar: \"lib/xlib/examples/useful\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/xlib/pixel.c -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"lib/xlib/pixel.c\"
else
echo shar: Extracting \"lib/xlib/pixel.c\" \(1332 characters\)
sed "s/^X//" >lib/xlib/pixel.c <<'END_OF_lib/xlib/pixel.c'
X#include "xlib.h"
X
XGeneric_Predicate (Pixel);
X
XGeneric_Simple_Equal (Pixel, PIXEL, pix);
X
XGeneric_Print (Pixel, "#[pixel 0x%lx]", PIXEL(x)->pix);
X
XObject Make_Pixel (val) unsigned long val; {
X    register char *p;
X    Object pix;
X
X    pix = Find_Object (T_Pixel, (GENERIC)0, Match_X_Obj, val);
X    if (Nullp (pix)) {
X	p = Get_Bytes (sizeof (struct S_Pixel));
X	SET (pix, T_Pixel, (struct S_Pixel *)p);
X	PIXEL(pix)->tag = Null;
X	PIXEL(pix)->pix = val;
X	Register_Object (pix, (GENERIC)0, (PFO)0, 0);
X    }
X    return pix;
X}
X
Xunsigned long Get_Pixel (p) Object p; {
X    Check_Type (p, T_Pixel);
X    return PIXEL(p)->pix;
X}
X
Xstatic Object P_Pixel_Value (p) Object p; {
X    return Make_Unsigned ((unsigned)Get_Pixel (p));
X}
X
Xstatic Object P_Black_Pixel (d) Object d; {
X    Check_Type (d, T_Display);
X    return Make_Pixel (BlackPixel (DISPLAY(d)->dpy,
X	DefaultScreen (DISPLAY(d)->dpy)));
X}
X
Xstatic Object P_White_Pixel (d) Object d; {
X    Check_Type (d, T_Display);
X    return Make_Pixel (WhitePixel (DISPLAY(d)->dpy, 
X	DefaultScreen (DISPLAY(d)->dpy)));
X}
X
Xinit_xlib_pixel () {
X    Generic_Define (Pixel, "pixel", "pixel?");
X    Define_Primitive (P_Pixel_Value,   "pixel-value",    1, 1, EVAL);
X    Define_Primitive (P_Black_Pixel,   "black-pixel",    1, 1, EVAL);
X    Define_Primitive (P_White_Pixel,   "white-pixel",    1, 1, EVAL);
X}
END_OF_lib/xlib/pixel.c
if test 1332 -ne `wc -c <lib/xlib/pixel.c`; then
    echo shar: \"lib/xlib/pixel.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 9 \(of 14\).
cp /dev/null ark9isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
    if test ! -f ark${I}isdone ; then
	MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 14 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0