;; Space Combat, by Kenneth B. Russell (kbrussel@media.mit.edu)
(require 'random)
(format #t "Instructions:\n")
(format #t " Left/right arrows to steer\n")
(format #t " Up arrow to accelerate\n")
(format #t " Control key to fire\n")
(format #t " The game board wraps around; going off one side will warp\n")
(format #t " you to the other side.\n")
(define (randomize-loop i)
(if (> (modulo i 173) 0)
(begin
; (display "Randomizing...\n")
(random 5)
(randomize-loop (- i 1)))))
(randomize-loop (get-universal-time))
(define M_PI 3.14159265358979323846)
;;; SICP-ish simple object system for dealing similarly
;;; with Scheme and C++ objects using "send"
(define (send object message . args)
(if (C++-object? object)
(eval `(-> ,object ',message ,@args))
(let ((method (get-method object message)))
(if (not (no-method? method))
(apply method (cons object args))
(error "No method named" message)))))
(define (get-method object message)
(object message))
(define (no-method method)
'no-method)
(define (no-method? method)
(eq? method 'no-method))
;;;;;;;;;;;;;;;;
;; NETWORKING ;;
;;;;;;;;;;;;;;;;
;; Global switch for network mode on or off
(define *single-player-mode* #f)
(define *combat-port* 16666)
(define *combat-address* "224.14.16.18")
(define *local-ip-address* #f)
(define *local-user-name* #f)
(define *local-score* 0)
(define (long-to-dot-format addr)
;; b4 b3 b2 b1, hi to low bytes
(let ((b1 (modulo addr 256))
(b2 (modulo (quotient addr 256) 256))
(b3 (modulo (quotient addr 65536) 256))
(b4 (modulo (quotient addr 16777216) 256)))
(apply string-append
(list (number->string b4) "."
(number->string b3) "."
(number->string b2) "."
(number->string b1)))))
(define (get-local-user-name)
(format #t "Please type your name: ")
(set! *local-user-name* (read)))
(if (not *single-player-mode*)
(begin
(define *sc* (new-SocketClient *combat-port*))
(send *sc* 'setUsingMulticast 1)
(set! *local-ip-address* (send *sc* 'getLocalIPAddress))
(get-local-user-name)
(send *sc* 'setSuppressingMulticastLoopback 1)
(send *sc* 'connectToServer *combat-address*)))
(define (process-network-input)
;; NETWORK MODE ONLY: read in all messages from network
;; and send them to appropriate objects.
;; Note that since we need to know the address of the machine
;; where the object came from, we must use read-object-from-network-multi.
(let ((obj-pair (read-object-from-network-multi *sc*)))
(if (not (null? obj-pair))
(let* ((obj (car obj-pair))
(message (car obj))
(from-address (cdr obj-pair)))
; (format #t "Got message: ~s\n" obj)
(cond ((eq? message 'new-pellet)
(new-Pellet (new-SbVec3f (cadr obj))
(new-SbVec3f (caddr obj))
(cadddr obj)
*root*
from-address))
((eq? message 'key-state)
(dispatch-key-state obj from-address))
((eq? message 'sync)
(dispatch-sync obj from-address))
((eq? message 'blown-up-by)
; (format #t "Got message: ~s\n" obj)
(dispatch-blow-up obj from-address))
(else (format #t "Unknown message received: ~s\n" message))
)))))
(define (ship-list-dispatch which-ship found-proc not-found-proc)
;; found-proc is a procedure of one argument (the ship)
;; not-found-proc is a procedure of no arguments.
(define (aux the-list)
(if (not (null? the-list))
(begin
(if (eq? which-ship (send (car the-list) 'getFromLocation))
(found-proc (car the-list))
(aux (cdr the-list))))
(not-found-proc)))
(aux *ship-list*))
(define (dispatch-key-state obj which-ship)
(let ((key-state (cadr obj)))
(ship-list-dispatch which-ship
(lambda (ship)
(send ship 'setKeyState key-state))
(lambda () #f))))
(define (dispatch-sync obj which-ship)
(let ((trans (cadr obj))
(angle (caddr obj))
(velocity (cadddr obj))
(key-state (car (cddddr obj)))
(name (cadr (cddddr obj)))
(score (caddr (cddddr obj))))
(ship-list-dispatch which-ship
(lambda (ship)
(send ship 'setPosition trans)
(send ship 'setDirection angle)
(send ship 'setSpeed velocity)
(send ship 'setKeyState key-state)
(send ship 'setScore score)
; (send ship 'setKeyState '((left . #f)
; (right . #f)
; (up . #f)))
)
(lambda ()
(let ((cur-ship (new-Ship trans
angle
*root*
which-ship
name)))
(send cur-ship 'setSpeed velocity)
(send cur-ship 'setKeyState key-state)
(send cur-ship 'setScore score)
; (send cur-ship 'setKeyState '((left . #f)
; (right . #f)
; (up . #f)))
))
)))
(define (dispatch-blow-up obj which-ship)
(let ((killer (cadr obj)))
(ship-list-dispatch which-ship
(lambda (ship)
(send ship 'blowUp killer))
(lambda () #f))
;; Update score
(if (eq? killer *local-ip-address*)
(set! *local-score* (1+ *local-score*)))))
;;;;;;;;;;;;;;;;;;
;; SCORING TEXT ;;
;;;;;;;;;;;;;;;;;;
(define (new-TextScore scene-root)
(define root (new-SoSeparator))
(define text (new-SoText3))
(send root 'addChild text)
(send scene-root 'addChild root)
(define scores '())
(let ((self
(lambda (message)
(cond ((eq? message 'regenerate)
(lambda (self)
(let ((i 0))
(for-each
(lambda (score-pair)
(send (send text 'string)
'set1Value i
(new-SbString
(string-append
(symbol->string (car score-pair))
": "
(number->string (cdr score-pair)))))
(set! i (1+ i)))
scores))))
((eq? message 'updatePlayer)
;; Adds player to list if necessary
(lambda (self player-name new-score)
(let ((score-pair (assq player-name scores)))
(if score-pair
(set-cdr! score-pair new-score)
(set! scores (cons (cons player-name
new-score)
scores)))
(send self 'regenerate))))
((eq? message 'getPlayerScore)
(lambda (self player)
(let ((score-pair (assq player scores)))
(if score-pair
(cdr score-pair)
#f))))
))))
self))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GAME REGION AND BOARD ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *game-region-size* 80.0) ;; square this many units on a side
(define (game-random-position)
(let ((x (random *game-region-size*))
(y 0.0)
(z (random *game-region-size*)))
(vector x y z)))
(define (game-random-direction)
(random (* M_PI 2.0)))
;; Defining *display-game-board* to be true turns
;; on the hexagonal game board.
(define *display-game-board* #t)
(define *ground-depth* -1.0)
(define (new-HexGameBoard x-size z-size x-res z-res scene-root)
(define root (new-SoSeparator))
(define coords (new-SoCoordinate3))
(define trans (new-SoTranslation))
(define bind (new-SoMaterialBinding))
(define mat (new-SoMaterial))
(define fs (new-SoIndexedFaceSet))
(addChildren root coords trans bind mat fs)
(send scene-root 'addChild root)
(let ((self
(lambda (message)
(cond ((eq? message 'generate)
(lambda (self)
(set-mfield-values! (send coords 'point) 0
(send self 'generateCoords))
(set-mfield-values! (send mat 'diffuseColor) 0
'(#(0.7 0.5 0.1)
#(0.6 0.4 0.1)
#(0.5 0.3 0.1)))
(send (send bind 'value) 'setValue
SoMaterialBinding::PER_FACE_INDEXED)
(set-mfield-values! (send fs 'coordIndex) 0
(send self 'generateCoordIndices))
(set-mfield-values! (send fs 'materialIndex) 0
(send self 'generateMaterialIndices))
))
((eq? message 'generateCoords)
(lambda (self)
(let ((x-step (/ x-size x-res))
(z-step (/ z-size (* 2.0 z-res))))
(define (vert-loop z)
(define (horiz-loop x z-pos)
(if (> x (* 2 x-res))
(vert-loop (1+ z))
(if (odd? x)
(cons (vector (+ (* x-step
(floor (/ x 2)))
(/ x-step 3.0))
0.0
z-pos)
(horiz-loop (1+ x) z-pos))
(cons (vector (* x-step
(floor (/ x 2)))
0.0
z-pos)
(horiz-loop (1+ x) z-pos)))))
(if (> z (* 2 z-res))
'()
(horiz-loop 0 (* z z-step))))
(vert-loop 0))))
((eq? message 'generateCoordIndices)
(lambda (self)
(define (row-index x z)
(+ x (* z (1+ (* 2 x-res)))))
(define (vert-loop z)
(define (horiz-loop x)
(if (>= x (* 2 x-res))
(vert-loop (1+ z))
(if (odd? x)
;; Make square
(cons (row-index x z)
(cons (row-index x (1+ z))
(cons (row-index (1+ x) (1+ z))
(cons (row-index (1+ x) z)
(cons -1
(horiz-loop
(1+ x)))))))
;; Else, make pair of triangles
;; oriented in appropriate direction
(if (or (and (zero? (modulo x 4))
(even? z))
(and (not (zero? (modulo x 4)))
(odd? z)))
;; First directional pair
(cons (row-index x z)
(cons (row-index x (1+ z))
(cons (row-index (1+ x)
(1+ z))
(cons -1
(cons (row-index x z)
(cons (row-index (1+ x) (1+ z))
(cons (row-index (1+ x) z)
(cons -1
(horiz-loop (1+ x))))))))))
;; Second directional pair
(cons (row-index x z)
(cons (row-index x (1+ z))
(cons (row-index (1+ x) z)
(cons -1
(cons (row-index x (1+ z))
(cons (row-index (1+ x) (1+ z))
(cons (row-index (1+ x) z)
(cons -1
(horiz-loop (1+ x))))))))))
)
)
)
)
(if (>= z (* 2 z-res))
'()
(horiz-loop 0)))
(vert-loop 0)))
((eq? message 'generateMaterialIndices)
(lambda (self)
;; 6-state FSM implementing coloring algorithm.
(define (state which-state)
(cond ((eq? which-state 0)
'(0 2))
((eq? which-state 1)
'(0 1))
((eq? which-state 2)
'(2 1))
((eq? which-state 3)
'(2 0))
((eq? which-state 4)
'(1 0))
((eq? which-state 5)
'(1 2))
(else '())))
(define (vert-loop z)
(define (horiz-loop x i j)
(if (>= x (* 3 x-res))
(vert-loop (1+ z))
(if (>= i 2)
(cons (list-ref (state (modulo z 6)) j)
(horiz-loop (1+ x) 0 (- 1 j)))
(cons (list-ref (state (modulo z 6)) j)
(horiz-loop (1+ x) (1+ i) j)))))
(if (>= z (* 2 z-res))
'()
(horiz-loop 0 2 0)))
(vert-loop 0)))
((eq? message 'setTranslation)
(lambda (self new-trans)
(send (send trans 'translation)
'setValue new-trans)))
;; Debugging help for the C++ side of things ;-)
((eq? message 'getGeometry)
(lambda (self)
root))
((eq? message 'remove)
(send scene-root 'removeChild root))
))))
(send self 'generate)
self))
;;;;;;;;;;;;;
;; PELLETS ;;
;;;;;;;;;;;;;
(define *pellet-list* '())
(define *pellet-velocity* 10.0)
(define *pellet-expire-time* 0.5) ;; in seconds.
(define (update-pellets)
(define (expire-rest cur-pos next-pos)
(if (not (null? next-pos))
(let ((cur-pellet (car next-pos)))
(if (send cur-pellet 'checkExpired)
(begin
(set-cdr! cur-pos (cdr next-pos))
(set! next-pos (cdr cur-pos))))))
(if (not (null? next-pos))
(expire-rest next-pos (cdr next-pos))))
(define (expire-first)
(if (not (null? *pellet-list*))
(let ((cur-pellet (car *pellet-list*)))
(if (send cur-pellet 'checkExpired)
(begin
(set! *pellet-list* (cdr *pellet-list*))
(expire-first))
(expire-rest *pellet-list* (cdr *pellet-list*))))))
(for-each (lambda (pellet)
;; In network mode we aren't allowed to tell other ships
;; to blow up
(if *single-player-mode*
(for-each (lambda (ship)
(send pellet 'collideWithShip ship))
*ship-list*)
(send pellet 'collideWithShip *local-ship*)))
*pellet-list*)
(expire-first)
)
;; Pellet geometry must have a bounding cube of
;; ((* *pellet-geometry-bbox* -1.0)..*pellet-geometry-bbox*)
;; in every dimension
(define *pellet-geometry-bbox* 0.1)
(define *pellet-geometry* (new-SoSeparator))
(send *pellet-geometry* 'ref)
(let ((coords (new-SoCoordinate3))
(sf (new-SoScale))
(hints (new-SoShapeHints))
(mat (new-SoMaterial))
(fs (new-SoFaceSet)))
;; 8 triangles
(set-mfield-values! (send coords 'point) 0
'(#(0 0 1) #(1 0 0) #(0 1 0)
#(1 0 0) #(0 0 -1) #(0 1 0)
#(0 0 -1) #(-1 0 0) #(0 1 0)
#(-1 0 0) #(0 0 1) #(0 1 0)
#(1 0 0) #(0 0 1) #(0 -1 0)
#(0 0 -1) #(1 0 0) #(0 -1 0)
#(-1 0 0) #(0 0 -1) #(0 -1 0)
#(0 0 1) #(-1 0 0) #(0 -1 0)))
(set-mfield-values! (send fs 'numVertices) 0
'(3 3 3 3 3 3 3 3))
(send (send hints 'vertexOrdering)
'setValue SoShapeHints::COUNTERCLOCKWISE)
(send (send hints 'shapeType)
'setValue SoShapeHints::SOLID)
(send (send sf 'scaleFactor)
'setValue *pellet-geometry-bbox*
*pellet-geometry-bbox*
*pellet-geometry-bbox*)
(send (send mat 'diffuseColor) 'setValue 0.8 0.8 0.2)
(addChildren *pellet-geometry* sf coords hints mat fs))
(define (new-Pellet starting-pos velocity-vector
ship-velocity scene-root . from-where)
;; starting-pos and velocity-vector are SbVec3fs
;; ship-velocity is a float
;; scene-root is the root to which this pellet's geometry
;; will be added. Automatically removes itself once it
;; gets out of range
(define root (new-SoSeparator))
(define xf (new-SoTransform))
(send root 'addChild xf)
(send root 'addChild *pellet-geometry*)
(define interp (new-SoInterpolateVec3f))
(send (send interp 'input0) 'setValue starting-pos)
(let ((ending-pos (send starting-pos 'operator+
(send velocity-vector 'operator*
(/ (+ *pellet-velocity* ship-velocity)
(send velocity-vector 'length))))))
; (format #t "Starting position of pellet was ~s\n"
; (send starting-pos 'getValue))
; (format #t "Ending position of pellet was ~s\n"
; (send ending-pos 'getValue))
(send (send interp 'input1) 'setValue ending-pos))
(define elt (new-SoElapsedTime))
(define calc (new-SoCalculator))
(send (send calc '_a) 'connectFrom (send elt 'timeOut))
(send (send calc '_b) 'setValue *pellet-expire-time*)
(send (send calc 'expression) 'setValue "oa=a/b")
(send (send interp 'alpha) 'connectFrom (send calc '_oa))
(send (send xf 'translation) 'connectFrom (send interp 'output))
(send scene-root 'addChild root)
;; Network address of machine which fired this pellet
;; (network mode only)
(define from-machine #f)
(if (not (null? from-where))
(set! from-machine (car from-where)))
(let ((self
(lambda (message)
(cond ((eq? message 'getGeometry)
(lambda (self)
root))
((eq? message 'checkExpired)
;; Checks to see whether this pellet is
;; out of range.
(lambda (self)
(if (>= (send (send interp 'alpha) 'getValue) 1.0)
(begin
(send self 'remove)
#t)
#f)))
((eq? message 'collideWithShip)
;; Checks the current ship list for a collision.
;; Tells that ship to blow up if one was found.
;; Very cheesy; 2-D non-rotated squares.
(lambda (self ship)
(let ((posn (send ship 'getPosition))
(my-posn (send (send xf 'translation)
'getValue)))
(if (and (< (abs (- (-> posn 'operator-brackets 0)
(-> my-posn 'operator-brackets 0)))
(+ *pellet-geometry-bbox*
*ship-geometry-bbox*))
(< (abs (- (-> posn 'operator-brackets 2)
(-> my-posn 'operator-brackets 2)))
(+ *pellet-geometry-bbox*
*ship-geometry-bbox*)))
(send ship 'blowUp
(send self 'getFromLocation))))))
((eq? message 'remove)
(lambda (self)
(send scene-root 'removeChild root)))
((eq? message 'getFromLocation)
;; Returns network address of machine which
;; created this pellet, in network mode.
;; Returns #f in single player mode, or
;; if this pellet actually came from this machine.
(lambda (self)
from-machine))
))))
(set! *pellet-list* (cons self *pellet-list*))
(if (not *single-player-mode*)
;; If from-where is NULL, then the local ship fired this shot.
;; Send out notification to the network.
(if (null? from-where)
(write-object-to-network
`(new-pellet ,(send starting-pos 'getValue)
,(send velocity-vector 'getValue)
,ship-velocity)
*sc*)))
self))
;;;;;;;;;;;
;; RADAR ;;
;;;;;;;;;;;
(define (new-Radar scene-root)
(define root (new-SoSeparator))
(define coords (new-SoCoordinate3))
(define mat (new-SoMaterial))
(send (send mat 'emissiveColor) 'setValue 0.8 0.8 0.8)
(define style (new-SoDrawStyle))
(define xform (new-SoTransform))
(define pset (new-SoPointSet))
(addChildren root coords mat style xform pset)
; (addChildren root coords mat style xform (new-SoCone))
(send scene-root 'addChild root)
(define tmp-rot (new-SbRotation))
(define up-vec (new-SbVec3f 0 1 0))
(define tmp-vec (new-SbVec3f))
(let ((self
(lambda (message)
(cond ((eq? message 'updateFromShipList)
(lambda (self ship-list)
(let ((index 0)
(my-pos (send *local-ship* 'getPosition)))
(for-each
(lambda (ship)
(send tmp-vec 'setValue
(send (send ship 'getPosition) 'getValue))
(send tmp-vec 'operator-=
(send *local-ship* 'getPosition))
(send tmp-rot 'setValue up-vec
(- 0.0
(send *local-ship* 'getDirection)))
(send tmp-rot 'multVec tmp-vec tmp-vec)
(send (send coords 'point)
'set1Value index tmp-vec)
(set! index (1+ index)))
ship-list))
(let ((sl-length (length ship-list)))
(send (send coords 'point) 'setNum sl-length)
(send (send pset 'numPoints) 'setValue sl-length))))
((eq? message 'setScale)
(lambda (self new-scale)
(send (send xform 'scaleFactor)
'setvalue new-scale new-scale new-scale)))
((eq? message 'getScale)
(lambda (self)
(send (send (send xform 'scaleFactor) 'getValue)
'operator-brackets 0)))
((eq? message 'setPosition)
(lambda (self new-position)
(send (send xform 'translation)
'setValue new-position)))
((eq? message 'getPosition)
(lambda (self)
(send (send (send xform 'translation) 'getValue)
'getValue)))
((eq? message 'setRotation)
(lambda (self new-axis new-angle)
(if (SbVec3f? new-axis)
(send (send xform 'rotation)
'setValue new-axis new-angle)
(send (send xform 'rotation)
'setValue (new-SbVec3f new-axis) new-angle))))
((eq? message 'getRotation)
(lambda (self)
(let ((ang 0.0))
(send (send xform 'rotation)
'getValue tmp-vec ang)
(cons (send tmp-vec 'getValue) ang))))
((eq? message 'setPointSize)
(lambda (self new-point-size)
(send (send style 'pointSize)
'setValue new-point-size)))
((eq? message 'setColor)
(lambda (self r g b)
(send (send mat 'emissiveColor)
'setValue r g b)))
((eq? message 'remove)
;; It is not valid to reference this Radar object
;; after calling the remove method.
(lambda (self)
(send scene-root 'removeChild root)))
))))
;; These parameters obtained experimentally
(send self 'setPointSize 3)
(send self 'setPosition '#(0.7 1.6 1))
(send self 'setScale 0.0025)
(send self 'setRotation '#(1 0 0) (/ M_PI 2.0))
self))
;;;;;;;;;;;
;; SHIPS ;;
;;;;;;;;;;;
(define *ship-list* '())
;; Ship geometry must have a bounding cube of
;; ((* *ship-geometry-bbox* -1.0)..*ship-geometry-bbox*)
;; in every dimension
(define *ship-geometry-bbox* 1.0)
(define *ship-geometry* (new-SoSeparator))
(send *ship-geometry* 'ref)
(let* ((coords (new-SoCoordinate3))
(sf (new-SoScale))
(hints (new-SoShapeHints))
(color (new-SoBaseColor))
(mbind (new-SoMaterialBinding))
(ifs (new-SoIndexedFaceSet))
(ship-top (new-SbVec3f '#(0 0.6 0.8)))
(ship-width 0.8)
(ship-left (new-SbVec3f `#(,(* -1.0 ship-width)
0.0
1.0)))
(ship-right (new-SbVec3f `#(,ship-width
0.0
1.0)))
(ship-front (new-SbVec3f 0 0 -1)))
;; 4 triangles
(set-mfield-values! (send coords 'point) 0
`(,ship-front
,ship-left
,ship-right
,ship-top))
(set-mfield-values! (send ifs 'coordIndex) 0
`(0 1 3 ,SO_END_FACE_INDEX
1 2 3 ,SO_END_FACE_INDEX
2 0 3 ,SO_END_FACE_INDEX
0 2 1 ,SO_END_FACE_INDEX))
(set-mfield-values! (send ifs 'materialIndex) 0
`(0 1 0 2))
(set-mfield-values! (send ifs 'normalIndex) 0
`(0 1 2 3))
(set-mfield-values! (send color 'rgb) 0
'(#(0.2 0.2 0.8)
#(0.8 0.2 0.2)
#(0.6 0.6 0.6)))
(send (send sf 'scaleFactor)
'setValue *ship-geometry-bbox*
*ship-geometry-bbox*
*ship-geometry-bbox*)
(send (send hints 'vertexOrdering)
'setValue SoShapeHints::COUNTERCLOCKWISE)
(send (send hints 'shapeType)
'setValue SoShapeHints::SOLID)
(send (send mbind 'value) 'setValue SoMaterialBinding::PER_FACE_INDEXED)
(addChildren *ship-geometry* sf hints coords mbind color ifs))
;; Ship shadows can be turned off/on by
;; defining *display-ship-shadows* to be #f/#t
(define *display-ship-shadows* #t)
(define *ship-shadow-geometry* (new-SoSeparator))
(send *ship-shadow-geometry* 'ref)
(let* ((coords (new-SoCoordinate3))
(sf (new-SoScale))
(hints (new-SoShapeHints))
(mat (new-SoMaterial))
(mbind (new-SoMaterialBinding))
(ifs (new-SoIndexedFaceSet))
(ship-width 0.8)
(ship-left (new-SbVec3f `#(,(* -1.0 ship-width)
0.0
1.0)))
(ship-right (new-SbVec3f `#(,ship-width
0.0
1.0)))
(ship-front (new-SbVec3f 0 0 -1)))
;; 1 triangle
(set-mfield-values! (send coords 'point) 0
`(,ship-left
,ship-right
,ship-front))
(set-mfield-values! (send ifs 'coordIndex) 0
`(0 1 2 ,SO_END_FACE_INDEX))
(send (send ifs 'materialIndex) 'setValue 0)
(send (send mat 'diffuseColor) 'setValue '#(0.0 0.0 0.0))
(send (send mat 'transparency) 'setValue 0.2)
(send (send sf 'scaleFactor)
'setValue *ship-geometry-bbox*
*ship-geometry-bbox*
*ship-geometry-bbox*)
(send (send hints 'vertexOrdering)
'setValue SoShapeHints::COUNTERCLOCKWISE)
(send (send hints 'shapeType)
'setValue SoShapeHints::SOLID)
(send (send mbind 'value) 'setValue SoMaterialBinding::PER_FACE_INDEXED)
(addChildren *ship-shadow-geometry* sf hints coords mbind mat ifs))
(define *ship-max-velocity* 7.0)
(define *ship-max-velocity-framecnt* 5) ;; takes 5 updates with fwd key down
;; to get to max vel
(define *ship-velocity-increment* (/ *ship-max-velocity*
*ship-max-velocity-framecnt*))
(define *ship-secs-per-turn* 4) ;; 4 seconds to do a 360
(define *ship-ang-velocity* (/ (* 2 M_PI)
*ship-secs-per-turn*))
(define *ship-default-forward* (new-SbVec3f 0 0 -1))
;; Convenience function for removing ship from global ship list
;; NOTE. Only removes the first instance of this ship.
(define (remove-ship-from-list ship)
(define (remove-from-rest cur-pos next-pos)
(if (not (null? next-pos))
(let ((cur-ship (car next-pos)))
(if (eq? ship cur-ship)
(set-cdr! cur-pos (cdr next-pos))
(if (not (null? next-pos))
(remove-from-rest next-pos (cdr next-pos)))))))
(define (remove-from-first)
(if (not (null? *ship-list*))
(let ((cur-ship (car *ship-list*)))
(if (eq? ship cur-ship)
(set! *ship-list* (cdr *ship-list*))
(remove-from-rest *ship-list* (cdr *ship-list*))))))
(remove-from-first))
(define (new-Ship initial-pos initial-dir scene-root . args)
;; initial-pos is an SbVec3f indicating the ship's initial translation
;; initial-dir is a float from 0 to 2*PI
(define root (new-SoSeparator))
(define geom-root (new-SoSeparator))
(define shadow-root (new-SoSeparator))
(addChildren root geom-root shadow-root)
;; Geometry
(define xl (new-SoTranslation))
(define rot (new-SoRotationXYZ))
(define drot (new-SoRotationXYZ)) ;; local rotation;
;; reset in updateState
(define lxl (new-SoTranslation)) ;; local translation;
;; reset in updateState
(send (send xl 'translation) 'setValue initial-pos)
(send (send rot 'axis) 'setValue SoRotationXYZ::Y)
(send (send rot 'angle) 'setValue initial-dir)
(send (send drot 'axis) 'setValue SoRotationXYZ::Y)
(addChildren geom-root xl rot drot lxl *ship-geometry*)
;; Shadow (only if *display-ship-shadows* is not false)
(if *display-ship-shadows*
(begin
(define shadow-trans (new-SoTranslation))
(send (send shadow-trans 'translation) 'setValue
*ground-depth*
(* 0.9 *ground-depth*)
(* -1.0 *ground-depth*))
(addChildren shadow-root xl shadow-trans rot lxl *ship-shadow-geometry*)
))
(send scene-root 'addChild root)
;; Make calculator. Use it for both forward motion and turning.
(define velocity 0.0)
(define ang-velocity 0.0)
(define calc (new-SoCalculator))
(define elt (new-SoElapsedTime))
(send (send calc '_a) 'connectFrom (send elt 'timeOut))
(send (send calc '_b) 'setValue velocity)
(send (send calc '_c) 'setValue ang-velocity)
(send (send calc 'A) 'setValue *ship-default-forward*)
(send (send calc 'expression) 'setValue "oA=A*a*b;oa=a*c")
(send (send lxl 'translation) 'connectFrom (send calc 'oA))
(send (send drot 'angle) 'connectFrom (send calc '_oa))
(define sb-rot (new-SbRotation))
(define tmp-vec (new-SbVec3f))
(define up-vec (new-SbVec3f 0 1 0))
;; Key state for this ship.
;; Used so we don't have to send position information over the net,
;; only keypresses.
;; NOTE: can NOT allocate key-state like this:
;; (define key-state '((left . #f) (right . #f) (up . #f)))
;; not allowed to mutate literals! See R4RS. (I didn't know that...)
(define key-state (list (cons 'left #f)
(cons 'right #f)
(cons 'up #f)))
;; Network mode.
;; This contains the address of the machine which is
;; controlling this ship, or #f if it's the local ship.
(define from-machine #f)
(define user-name #f)
(define score 0)
(if (not (null? args))
(begin
(set! from-machine (car args))
(set! user-name (cadr args))))
(let ((self
(lambda (message)
(cond ((eq? message 'getGeometry)
(lambda (self)
root))
((eq? message 'speedUp)
(lambda (self)
(set! velocity (+ velocity
*ship-velocity-increment*))
(if (> velocity *ship-max-velocity*)
(set! velocity *ship-max-velocity*))
(send (send calc '_b) 'setValue velocity)))
((eq? message 'slowDown)
(lambda (self)
(set! velocity (- velocity
*ship-velocity-increment*))
(if (< velocity 0.0)
(set! velocity 0.0))
(send (send calc '_b) 'setValue velocity)))
((eq? message 'turnLeft)
(lambda (self)
(set! ang-velocity *ship-ang-velocity*)
(send (send calc '_c) 'setValue ang-velocity)))
((eq? message 'turnRight)
(lambda (self)
(set! ang-velocity (* -1.0 *ship-ang-velocity*))
(send (send calc '_c) 'setValue ang-velocity)))
((eq? message 'stopTurning)
(lambda (self)
(set! ang-velocity 0.0)
(send (send calc '_c) 'setValue ang-velocity)))
((eq? message 'setPosition)
(lambda (self new-position)
(send (send xl 'translation)
'setValue new-position)))
((eq? message 'getPosition)
(lambda (self)
(send (send xl 'translation) 'getValue)))
((eq? message 'setDirection)
(lambda (self new-direction)
(send (send rot 'angle)
'setValue new-direction)))
((eq? message 'getDirection)
(lambda (self)
(send (send rot 'angle) 'getValue)))
((eq? message 'setSpeed)
(lambda (self new-speed)
(set! velocity new-speed)
(send (send calc '_b) 'setValue velocity)))
((eq? message 'setKeyDown)
(lambda (self which-key)
(let ((key-pair (assq which-key key-state)))
(if key-pair
(begin
(set-cdr! key-pair #t)
#t)
#f))
(if (not *single-player-mode*)
;; If we're the local ship, send out
;; our key state to the network
(if (eq? self *local-ship*)
(send self 'sendKeyState)))
))
((eq? message 'setKeyUp)
(lambda (self which-key)
(let ((key-pair (assq which-key key-state)))
(if key-pair
(begin
(set-cdr! key-pair #f)
#t)
#f))
(if (not *single-player-mode*)
;; If we're the local ship, send out
;; our key state to the network
(if (eq? self *local-ship*)
(send self 'sendKeyState)))
))
((eq? message 'getKeyState)
(lambda (self)
key-state))
((eq? message 'setKeyState)
(lambda (self new-key-state)
(for-each (lambda (state-pair)
(if (cdr state-pair)
(send self 'setKeyDown
(car state-pair))
(send self 'setKeyUp
(car state-pair))))
new-key-state)))
((eq? message 'sendKeyState)
(lambda (self)
;; NETWORK MODE only: send out key state to network.
;; Called from setKeyUp/Down. (To optimize number of
;; times we write key state to the network)
(write-object-to-network `(key-state ,key-state) *sc*)))
((eq? message 'sendSync)
(lambda (self)
;; NETWORK MODE ONLY: send out absolute position/
;; orientation/velocity/key state information to network.
(write-object-to-network
`(sync ,(send
(send
(send xl 'translation) 'getValue) 'getValue)
,(send (send rot 'angle) 'getValue)
,velocity
,key-state
,*local-user-name*
,*local-score*)
*sc*)))
((eq? message 'updateState)
(lambda (self)
;; Update velocity from key state
(if (and (cdr (assq 'left key-state))
(not (cdr (assq 'right key-state))))
(begin
; (display "turning left\n")
(send self 'turnLeft))
(if (and (cdr (assq 'right key-state))
(not (cdr (assq 'left key-state))))
(begin
; (display "turning right\n")
(send self 'turnRight))
(send self 'stopTurning)))
(if (cdr (assq 'up key-state))
(begin
; (display "speeding up\n")
(send self 'speedUp))
(begin
; (display "slowing down\n")
(send self 'slowDown)))
;; Add local rotation into global
(send (send rot 'angle) 'setValue
(+ (send (send rot 'angle) 'getValue)
(send (send drot 'angle) 'getValue)))
;; Add local translation into global
(send sb-rot 'setValue up-vec
(send (send rot 'angle) 'getValue))
(send sb-rot 'multVec
(send (send lxl 'translation) 'getValue)
tmp-vec)
(send (send xl 'translation) 'setValue
(send (send (send xl 'translation) 'getValue)
'operator+ tmp-vec))
(send (send elt 'reset) 'setValue)
;; If global translation is off the game board, warp
(let* ((my-trans (send (send xl 'translation) 'getValue))
(x (send my-trans 'operator-brackets 0))
(y (send my-trans 'operator-brackets 1))
(z (send my-trans 'operator-brackets 2)))
(if (> x *game-region-size*)
(set! x 0.0)
(if (< x 0.0)
(set! x *game-region-size*)))
(if (> z *game-region-size*)
(set! z 0.0)
(if (< z 0.0)
(set! z *game-region-size*)))
(send (send xl 'translation) 'setValue (vector x y z)))))
((eq? message 'fire)
(lambda (self)
(send sb-rot 'setValue up-vec
(send (send rot 'angle) 'getValue))
(send sb-rot 'multVec *ship-default-forward* tmp-vec)
(new-Pellet (send
(send (send xl 'translation) 'getValue)
'operator+ (send tmp-vec 'operator*
(* 3.0 *ship-geometry-bbox*)))
tmp-vec
velocity
scene-root)))
((eq? message 'blowUp)
(lambda (self pellet-location)
;; No explosion animation right now...sorry folks
(if (not (eq? self *local-ship*))
(begin
(remove-ship-from-list self)
(send scene-root 'removeChild root)
;; Add code to update score here?
)
(begin
(if (not *single-player-mode*)
(begin
;; Make sure we didn't blow ourselves up.
;; It's not a bug, it's a feature.
(if pellet-location
(begin
;; Send out notification that
;; we blew up here
(write-object-to-network
`(blown-up-by ,pellet-location) *sc*)
;; Start over from new posn
(send (send xl 'translation)
'setValue (game-random-position))
(send (send rot 'angle)
'setValue (game-random-direction))
;; Add code to update score here
))))))))
((eq? message 'getFromLocation)
;; Returns network address of machine which
;; created this ship, in network mode.
;; Returns #f in single player mode, or
;; if this ship is the local ship on this machine.
(lambda (self)
from-machine))
((eq? message 'getUserName)
;; Returns name of player controlling this
;; ship, in network mode.
;; Returns #f in single player mode, or
;; if this ship is the local ship on this machine.
(lambda (self)
user-name))
((eq? message 'getCameraNodes)
;; Returns nodes for positioning camera correctly.
(lambda (self)
(list xl rot)))
((eq? message 'setScore)
(lambda (self new-score)
(set! score new-score)))
((eq? message 'getScore)
(lambda (self)
score))
)
)))
(set! *ship-list* (cons self *ship-list*))
self))
(define (keypress-cb user-data event-callback)
(let ((event (send event-callback 'getEvent)))
(cond ((or (= 1 (SO_KEY_PRESS_EVENT event LEFT_CONTROL))
(= 1 (SO_KEY_PRESS_EVENT event RIGHT_CONTROL)))
(send *local-ship* 'fire)
(send event-callback 'setHandled))
((= 1 (SO_KEY_PRESS_EVENT event LEFT_ARROW))
(send *local-ship* 'setKeyDown 'left)
(send event-callback 'setHandled))
((= 1 (SO_KEY_RELEASE_EVENT event LEFT_ARROW))
(send *local-ship* 'setKeyUp 'left)
(send event-callback 'setHandled))
((= 1 (SO_KEY_PRESS_EVENT event RIGHT_ARROW))
(send *local-ship* 'setKeyDown 'right)
(send event-callback 'setHandled))
((= 1 (SO_KEY_RELEASE_EVENT event RIGHT_ARROW))
(send *local-ship* 'setKeyUp 'right)
(send event-callback 'setHandled))
((= 1 (SO_KEY_PRESS_EVENT event UP_ARROW))
(send *local-ship* 'setKeyDown 'up)
(send event-callback 'setHandled))
((= 1 (SO_KEY_RELEASE_EVENT event UP_ARROW))
(send *local-ship* 'setKeyUp 'up)
(send event-callback 'setHandled))
)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SENSORS and CALLBACKS ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ship-idle-cb user-data sensor)
(if (not *single-player-mode*)
(process-network-input))
(update-pellets)
(for-each (lambda (ship)
(send ship 'updateState))
*ship-list*)
(if (not *single-player-mode*)
(begin
(for-each (lambda (ship)
(if (not (eq? ship *local-ship*))
(send *text-score* 'updatePlayer
(send ship 'getUserName)
(send ship 'getScore))
(send *text-score* 'updatePlayer
*local-user-name*
*local-score*)))
*ship-list*)
(send *score-viewer* 'viewAll)))
(send *radar* 'updateFromShipList *ship-list*)
(send sensor 'schedule))
;; Base scene graph
(define *root* (new-SoSeparator))
(send *root* 'ref)
(define *cam-sep* (new-SoTransformSeparator))
(send *root* 'addChild *cam-sep*)
(define *ship-idle-sensor* (sensor new-SoIdleSensor ship-idle-cb))
(send *ship-idle-sensor* 'schedule)
;; Send sync information fairly often (though not every frame)
(define *ship-sync-interval* 1.0)
(define (ship-sync-cb user-data sensor)
(send *local-ship* 'sendSync))
(if (not *single-player-mode*)
(begin
(define *ship-sync-sensor* (sensor new-SoTimerSensor ship-sync-cb))
(send *ship-sync-sensor* 'setInterval (new-SbTime *ship-sync-interval*))
(send *ship-sync-sensor* 'schedule)))
(define ev-cb (new-SoEventCallback))
(send ev-cb 'addEventCallback
(SoKeyboardEvent::getClassTypeId)
(get-scheme-event-callback-cb)
(void-cast (callback-info keypress-cb)))
(send *root* 'addChild ev-cb)
;; Game board
(if *display-game-board*
(begin
(define *game-board* (new-HexGameBoard *game-region-size*
*game-region-size*
3 3 *root*))
(send *game-board* 'setTranslation `#(0 ,*ground-depth* 0))
))
;; Set up the local ship and camera transform nodes
(define *local-ship* (new-Ship (game-random-position)
(game-random-direction) *root*))
(define *cam-local-xlate* (new-SoTranslation))
(send (send *cam-local-xlate* 'translation) 'setValue 0.0 2.0 3.0)
(define *cam-local-rotate* (new-SoRotationXYZ))
(send (send *cam-local-rotate* 'axis) 'setValue SoRotationXYZ::X)
(send (send *cam-local-rotate* 'angle) 'setValue (* -1.0
(/ M_PI 7.0)))
(define *ship-xl* (car (send *local-ship* 'getCameraNodes)))
(define *ship-rot* (cadr (send *local-ship* 'getCameraNodes)))
(send *cam-sep* 'addChild *ship-xl*)
(send *cam-sep* 'addChild *ship-rot*)
(send *cam-sep* 'addChild *cam-local-xlate*)
(send *cam-sep* 'addChild *cam-local-rotate*)
(define *camera* (new-SoPerspectiveCamera))
(send *cam-sep* 'addChild *camera*)
;; Something to blow up
(if *single-player-mode*
(new-Ship (new-SbVec3f 10 0 -10) 0 *root*))
;; Main game viewer
(define *viewer* (examiner *root*))
(send *viewer* 'setViewing 0)
(send *viewer* 'setAutoClipping 0)
(send *viewer* 'setDecoration 0)
(send *viewer* 'setPopupMenuEnabled 0)
(send *viewer* 'setTitle "Combat")
(send (send *camera* 'nearDistance) 'setValue 0.1)
(send (send *camera* 'farDistance) 'setValue 100)
(send (send *camera* 'position) 'setValue 0 0 0)
;; Make the radar
;; Cheat. Place it in the local ship's scene graph
;; (so it stays aligned with it)
(define *radar* (new-Radar (SoSeparator-cast
(send (SoSeparator-cast
(send *local-ship* 'getGeometry))
'getChild 0))))
;; Game score text, for network mode
(if (not *single-player-mode*)
(begin
(define *score-root* (new-SoSeparator))
(send *score-root* 'ref)
(define *text-score* (new-TextScore *score-root*))
(send *text-score* 'updatePlayer *local-user-name* *local-score*)
(define *score-viewer* (examiner *score-root*))
(send *score-viewer* 'setDecoration 0)
(send *score-viewer* 'setPopupMenuEnabled 0)
(send *score-viewer* 'setTitle "Combat Scores")
(send *score-viewer* 'setSize (new-SbVec2s 200 390))))
$Id: combat.html,v 1.1 1998/11/17 06:18:24 kbrussel Exp $