(proclaim '(optimize (safety 0) (speed 3)))
(defmacro game2screen (x)
`(ash ,x -10))
(defmacro screen2game (x)
`(ash ,x 10))
(defvar *option-list* nil)
(defmacro define-option (name description default-value option-values)
"define a new compiler debugging option switch"
`(progn
(defparameter ,name ,default-value ,description)
(setq *option-list*
(delete-old-entry ',name *option-list*))
(push-end '(,name ,description ,@option-values) *option-list*)
nil))
(defmacro define-blank ()
`(push-end "" *option-list*))
(defun delete-old-entry (x l)
(delete x l :test #'(lisp:lambda (x y) (when (consp y) (eq x (car y))))))
(defun control-panel ()
(w:choose-variable-values *option-list* :label "Space War Options"))
(define-blank)
(define-option *min-floaters* "2Min number of floaters*" 0 (:non-negative-fixnum))
(define-option *max-floaters* "2Max number of floaters*" 1 (:non-negative-fixnum))
(define-blank)
(define-option *min-shooters* "2Min number of shooters*" 0 (:non-negative-fixnum))
(define-option *max-shooters* "2Max number of shooters*" 2 (:non-negative-fixnum))
(define-blank)
(define-option *min-healers* "2Min number of healers*" 1 (:non-negative-fixnum))
(define-option *max-healers* "2Max number of healers*" 2 (:non-negative-fixnum))
(define-blank)
(define-option *crystals* "2Bonus crystals*" :shields (:choose (:points :shields :none)))
(define-blank)
(define-option *min-warpers* "2Min number of warpers*" 0 (:non-negative-fixnum))
(define-option *max-warpers* "2Max number of warpers*" 1 (:non-negative-fixnum))
(define-option *warper-gravity* "2Warper has gravity*" nil (:boolean))
(define-blank)
(define-option *cloak-p* "2Player has cloak ability*" nil (:boolean))
(define-option *bullet-limit* "2Number of player bullets*" 5 (:non-negative-fixnum))
(define-option *player-bullet-life* "2Player bullet life*" 40 (:non-negative-fixnum))
(define-option *fragment-life* "2Explosion bullet life*" 100 (:non-negative-fixnum))
(define-blank)
(define-option *gravity-choice* "2Gravity at center*" :random (:choose (:attract :repel :none :random)))
(define-option *edge-action-choice* "2Edge action*" :random (:choose (:bounce :go-through :random)))
(define-blank)
(defconstant *turn-speed* 1)
(defconstant *max-shields* 400)
(defconstant *base-x* (screen2game 100))
(defconstant *player-thrust* (screen2game 1))
(defconstant *player-speed* (screen2game 7))
(defconstant *player-bullet-speed* (screen2game 8))
(defconstant *floater-speed* (screen2game 12))
(defconstant *shooter-speed* (screen2game 10))
(defconstant *warper-speed* (screen2game 5))
(defconstant *shooter-thrust* (screen2game 3))
(defconstant *warper-thrust* (screen2game 2))
(defconstant *healer-thrust* (screen2game 1))
(defconstant *shooter-bullet-life* 30)
(defconstant *shooter-bullet-speed* (screen2game 5))
(defconstant *fragment-speed* (screen2game 14))
(defconstant *healer-speed* (screen2game 9))
(defconstant *rotation* 32)
(defconstant *rot-factor* (/ 6.28318 *rotation*))
(defconstant *bsize/2* 10)
(defconstant *end-life* 150)
(defconstant *collision-grain* -4)
(defconstant *gravity-grain* -4)
(defvar *gravity*)
(defvar *edge-action*)
(defsubst limit (value bound)
(min (max value (- bound)) bound))
(defsubst square (x)
(* x x))
(defsubst cube (x)
(* x x x))
(defvar *keys* '((#\q #\e #\t #\u #\y) (#\ #\ #\0 #\return #\.)))
(defconstant *key-names* '("Turn left" "Turn right" "Thrust" "Fire" "Cloak"))
(setf (get :tyi 'w:choose-variable-values-keyword)
(list #'(lambda (x s) (format s "~:@C" x)) '(tyi)))
(defvar *key-alist*)
(loop initially (setq *key-alist* (list ""))
for player-num from 1
for pkeys in *keys* do
(loop for i from 0
for key in pkeys
collect
(list (locf key)
(format nil "Player #~d ~a" player-num (nth i *key-names*))
:tyi)
into alist
finally (nconc *key-alist* alist))
(push-end "" *key-alist*))
(defun define-keys ()
(w:choose-variable-values *key-alist* :label "Keyboard definitions"))
(defvar *cos* (make-array 32 :type 'art-fix))
(defvar *sin* (make-array 32 :type 'art-fix))
(loop for i from 0 below 32
for angle = (* i (/ 6.28318 32)) do
(setf (aref *cos* i) (truncate (* (cos angle) 1024)))
(setf (aref *sin* i) (truncate (* (sin angle) 1024))))
(unless (boundp 'fonts:space-duel)
(load "sys:mit.hacks;space-duel-font"))
(defflavor moving-object
(char
x-pos
y-pos
(x-speed 0)
(y-speed 0)
(alive-p t)
(size 32)
gsize/2
(trace t)
width
height
window)
()
:gettable-instance-variables
:settable-instance-variables
:inittable-instance-variables)
(defmethod (moving-object :after :init) (&rest ignore)
(setq width (send window :width))
(setq height (send window :height))
(setq gsize/2 (ash (screen2game size) -1)))
(defmethod (moving-object :reset) ()
(when alive-p
(send self :draw)))
(defmethod (moving-object :draw) ()
(when char
(w:prepare-sheet (window)
(tv:%draw-char fonts:space-duel char
(- (game2screen x-pos) *bsize/2*)
(- (game2screen y-pos) *bsize/2*)
w:alu-ior window))))
(defmethod (moving-object :erase) ()
(when char
(w:prepare-sheet (window)
(tv:%draw-char fonts:space-duel char
(- (game2screen x-pos) *bsize/2*)
(- (game2screen y-pos) *bsize/2*)
w:alu-andca window))))
(defmethod (moving-object :die) ()
(when alive-p
(send window :dealloc-object self)
(send self :erase)
(setq alive-p nil)))
(defmethod (moving-object :tick) ()
(when (eq alive-p t)
(send self :erase)
(case *gravity*
(:attract
(decf x-speed (send window :x-gravity x-pos y-pos))
(decf y-speed (send window :y-gravity x-pos y-pos)))
(:repel
(incf x-speed (send window :x-gravity x-pos y-pos))
(incf y-speed (send window :y-gravity x-pos y-pos))))
(incf x-pos x-speed)
(incf y-pos y-speed)
(case *edge-action*
(:bounce
(unless (< gsize/2 x-pos (- (screen2game width) gsize/2))
(setq x-speed (- x-speed))
(incf x-pos (* 2 x-speed)))
(unless (< gsize/2 y-pos (- (screen2game height) gsize/2))
(setq y-speed (- y-speed))
(incf y-pos (* 2 y-speed))))
(:go-through
(setq x-pos (+ gsize/2 (mod (- x-pos gsize/2) (- (screen2game width) (ash gsize/2 1)))))
(setq y-pos (+ gsize/2 (mod (- y-pos gsize/2) (- (screen2game height) (ash gsize/2 1)))))))
(send self :draw)
(when trace
(send window :mark size size (game2screen (- x-pos gsize/2)) (game2screen (- y-pos gsize/2))))
(when (and (eq *gravity* :attract)
(< (+ (square (- (game2screen x-pos) (lsh width -1)))
(square (- (game2screen y-pos) (lsh height -1))))
50))
(send self :warp t))
))
(defmethod (moving-object :warp) (&rest ignore)
(when alive-p
(send self :erase)
(let ((dist (- (ash (min width height) -1) size))
(angle (send window :warp-angle)))
(setq x-pos (+ (ash (screen2game width) -1) (* (aref *cos* angle) dist))
y-pos (+ (ash (screen2game height) -1) (* (aref *sin* angle) dist))))
(send self :draw)))
(defmethod (moving-object :collide-sound) (player &optional (pitch :noise))
(tv:reset-sound t)
(if (eq pitch :noise)
(progn
(tv:do-sound (tv:noise 0 0))
(tv:do-sound (tv:volume 3 0)))
(let ((voice (send player :number)))
(tv:do-sound (tv:tone voice pitch))
(tv:do-sound (tv:volume voice 0)))))
(defflavor player
(number
shields
character-offset
dir
bullet-count
cloak
(auto-move nil)
(score 0))
(moving-object)
(:default-init-plist
:trace nil)
:gettable-instance-variables
:settable-instance-variables
:inittable-instance-variables)
(defmethod (player :before :reset) ()
(setq alive-p t)
(setq shields 0)
(setq y-pos (+ (random (ash (screen2game height) -1))
(ash (screen2game height) -2)))
(setq bullet-count 0)
(setq x-speed 0)
(setq y-speed 0)
(when auto-move
(setq auto-move t))
(setq cloak nil)
(case number
(1 (setq character-offset 64)
(setq x-pos *base-x*)
(send self :set-direction 0))
(2 (setq character-offset 96)
(setq x-pos (- (screen2game width) *base-x*))
(send self :set-direction 16))))
(defmethod (player :set-direction) (d)
(setq dir (mod d *rotation*)))
(defmethod (player :before :draw) ()
(if cloak
(setq char nil)
(setq char (+ character-offset dir))))
(defmethod (player :after :tick) ()
(when alive-p
(when auto-move
(send self :chase))
(when cloak
(if (<= shields 50)
(setq cloak nil)
(send self :change-shields -1)))
(let ((speed (sqrt (+ (square x-speed) (square y-speed)))))
(unless (zerop speed)
(let ((player-drag (max (- speed *player-speed*) 0)))
(decf x-speed (truncate (/ (* player-drag x-speed) speed)))
(decf y-speed (truncate (/ (* player-drag y-speed) speed))))))))
(defmethod (player :chase) ()
(let ((victim (find-if #'(lambda (x) (not (eq x self))) (send window :players)))
(chase t)
(thrust t))
(unless (send victim :alive-p)
(setq chase nil)
(setq victim (or (find-if #'(lambda (x)
(and (typep x 'crystal) (send x :alive-p)))
(send window :objects))
(find-if #'(lambda (x)
(and (typep x 'healer) (send x :alive-p)))
(send window :objects))
self)))
(let* ((dx (- (send victim :x-pos) x-pos))
(dy (- (send victim :y-pos) y-pos))
(dist (round (sqrt (+ (* dx dx) (* dy dy)))))
(time (/ dist (+ (ash *player-speed* -1) *player-bullet-speed*)))
(vdir (if chase
(mod (- (round (* 5.093 (if (and (zerop dy) (zerop dx)) (random 6.28) (atan dy dx))))
(send victim :dir)
16) 32)))
angle ddir)
(incf dx (+ (* (send victim :x-speed) time)
(if chase (* (aref *cos* (send victim :dir)) time) 0)))
(incf dy (+ (* (send victim :y-speed) time)
(if chase (* (aref *sin* (send victim :dir)) time) 0)))
(when (eq *edge-action* :go-through)
(let ((width2 (ash (screen2game width) -1))
(height2 (ash (screen2game height) -1)))
(cond ((> dx width2) (decf dx (screen2game width)))
((< dx (- width2)) (incf dx (screen2game width))))
(cond ((> dy height2) (decf dy (screen2game height)))
((< dy (- height2)) (incf dy (screen2game height))))))
(setq angle (round (* 5.093 (if (and (zerop dy) (zerop dx)) (random 6.28) (atan dy dx)))))
(setq ddir (logand (- angle dir) 31))
(when chase
(when (and (< 2 (send victim :bullet-count) (1- *bullet-limit*))
(= vdir 0)
(or (>= (1+ bullet-count) *bullet-limit*)
(not (<= 4 ddir 28))
(> dist (lsh *player-speed* 2))))
(setq auto-move (+ 10 (* 13 (random 2)))))
(when (numberp auto-move)
(setq chase nil)
(setq ddir (logand (+ ddir auto-move) 31))
(when (or (>= (1+ (send victim :bullet-count)) *bullet-limit*)
(not (<= 2 (logand (- dir ddir) 31) 30)))
(setq thrust (not (< 8 ddir 24)))
(setq chase (not thrust))
(if (> auto-move 16)
(incf auto-move)
(decf auto-move)))
(when (or (<= 4 vdir 28))
(= 0 (logand auto-move 31))
(zerop (random 30))
(setq auto-move t)
(setq chase t))))
(cond ((< 0 ddir 16)
(send self :set-direction (1+ dir)))
((>= ddir 16)
(send self :set-direction (1- dir))))
(when thrust
(send self :thrust))
(when (or (and (>= *bullet-limit* *player-bullet-life*)
(typep victim 'player))
(and chase
(zerop (random (max (+ (lsh (if (> ddir 16) (- 32 ddir) ddir) 1)
(floor dist (lsh *player-speed* 1))
(if thrust -1 -3))
1)))))
(send self :fire)))))
(defmethod (player :thrust) ()
(send self :add-vector
(ash (* *player-thrust* (aref *cos* dir)) -10)
(ash (* *player-thrust* (aref *sin* dir)) -10)))
(defmethod (player :add-vector) (dx dy)
(incf x-speed dx)
(incf y-speed dy))
(defmethod (player :before :warp) (&optional damage)
(when damage
(send self :change-shields -80)))
(defmethod (player :fire) ()
(when (< bullet-count *bullet-limit*)
(incf bullet-count)
(send window
:make-bullet self
(+ x-pos (ash (* (+ gsize/2 (ash gsize/2 -1)) (aref *cos* dir)) -10))
(+ y-pos (ash (* (+ gsize/2 (ash gsize/2 -1)) (aref *sin* dir)) -10))
dir *player-bullet-speed*
x-speed y-speed *player-bullet-life* 2)))
(defmethod (player :toggle-cloak) ()
(setq cloak (not cloak))
(when cloak
(if (<= shields 50)
(setq cloak nil)
(send self :change-shields -1))))
(defmethod (player :auto-cloak) ()
(when auto-move
(let ((cloak? (send window :collidep self)))
(if cloak
(unless cloak?
(when (zerop (decf cloak))
(setq cloak nil)
(send self :draw)))
(when cloak?
(send self :toggle-cloak)
(when cloak
(setq cloak 5)
(send self :erase)))))))
(defmethod (player :kill-bullet) ()
(decf bullet-count))
(defmethod (player :turn-left) ()
(send self :set-direction (- dir *turn-speed*)))
(defmethod (player :turn-right) ()
(send self :set-direction (+ dir *turn-speed*)))
(defsubst collidep (object d)
(let ((dx (abs (- (send object :x-pos) x-pos)))
(dy (abs (- (send object :y-pos) y-pos))))
(and (< dx d) (< dy d))))
(defmethod (player :collidep) (object)
(when (and alive-p (not (eq object self)))
(collidep object (send object :gsize/2))))
(defmethod (player :change-shields) (x)
(when alive-p
(when (and (plusp x) (< shields *max-shields*))
(tv:do-sound (tv:volume number 0)))
(send self :draw-shields
(if (plusp x)
(min (- *max-shields* shields) x)
(min shields x)))
(setq shields (min (+ shields x) *max-shields*))
(when (< shields 0)
(send self :die)
(send window :blow-up x-pos y-pos)))
)
(defmethod (player :collide) (player)
(let* ((dxs (ash (- (send player :x-speed) x-speed) -1))
(dys (ash (- (send player :y-speed) y-speed) -1)))
(send self :collide-sound player)
(send player :set-x-speed (- dxs))
(send player :set-y-speed (- dys))
(setq x-speed dxs)
(setq y-speed dys)
(dotimes (i 2)
(send player :tick)
(send self :tick))
(let ((damage (* (game2screen (+ (abs dxs) (abs dys))) -3)))
(send player :change-shields damage)
(send self :change-shields damage))))
(defmethod (player :draw-shields) (d)
(let ((stats-window (send window :stats-window))
(s shields))
(when (< width 900)
(setq s (ash s -1)
d (ash d -1)))
(if (plusp d)
(if (= number 1)
(send stats-window :draw-line s 9 (+ s d) 9 5)
(send stats-window :draw-line (- width s) 9 (- width s d) 9 5))
(if (= number 1)
(send stats-window :draw-line s 9 (+ s d) 9 5 2)
(send stats-window :draw-line (- width s) 9 (- width (+ s d)) 9 5 2)))))
(defmethod (player :after :set-score) (ignore)
(send self :draw-score))
(defmethod (player :draw-score) ()
(send (send window :stats-window) :string-out-explicit
(format nil "~6,48d" score)
(+ (ash width -1) (if (= number 1) -80 20)) 4
nil nil fonts:medfnt w:normal))
(defflavor bullet
(owner
(rot nil)
char
time-left)
(moving-object)
(:default-init-plist
:size 22)
:gettable-instance-variables
:settable-instance-variables
:inittable-instance-variables)
(defmethod (bullet :before :reset) ()
(setq alive-p nil))
(defmethod (bullet :after :tick) ()
(when (and alive-p (zerop (decf time-left)))
(send self :die)))
(defmethod (bullet :before :die) ()
(when owner
(send owner :kill-bullet)))
(defmethod (bullet :collide) (player)
(send self :collide-sound player)
(send player :change-shields -15)
(send self :die))
(defflavor bad-guy
(damage)
(moving-object)
:inittable-instance-variables)
(defmethod (bad-guy :before :reset) ()
(setq x-pos (screen2game (+ 10 (* -20 (random 2)) (ash width -1))))
(setq y-pos (screen2game (+ 50 (random (- height 100))))))
(defmethod (bad-guy :collide) (player)
(let* ((dxs (ash (- (send player :x-speed) x-speed) -1))
(dys (ash (- (send player :y-speed) y-speed) -1))
(tds (/ *player-speed* (coerce (max (sqrt (+ (* dxs dxs) (* dys dys))) 1) 'float)))
(x-power (truncate (* dxs tds)))
(y-power (truncate (* dys tds))))
(send self :collide-sound player)
(send player :set-x-speed (- x-power))
(send player :set-y-speed (- y-power))
(setq x-speed x-power)
(setq y-speed y-power)
(dotimes (i 3)
(send player :tick)
(send self :tick)))
(send player :change-shields damage))
(defflavor floater
()
(bad-guy)
(:default-init-plist
:damage -10))
(defmethod (floater :before :reset) ()
(let ((dir (random 32)))
(setq x-speed (ash (* *floater-speed* (aref *cos* dir)) -10))
(setq y-speed (ash (* *floater-speed* (aref *sin* dir)) -10))))
(defflavor shooter
(victim)
(bad-guy)
:gettable-instance-variables
:settable-instance-variables
(:default-init-plist
:damage -15))
(defmethod (shooter :before :reset) ()
(setq victim nil)
(setq x-speed 0)
(setq y-speed 0))
(defmethod (shooter :before :tick) ()
(when alive-p
(when (or (not victim)
(not (send victim :alive-p))
(send victim :auto-move)
(zerop (random 100)))
(setq victim (nth (random (length (send window :players))) (send window :players))))
(when (and (zerop (random 8)) (send victim :alive-p))
(let* ((dx (- (send victim :x-pos) x-pos))
(dy (- (send victim :y-pos) y-pos))
(dist (max (sqrt (+ (* dx dx) (* dy dy))) 1)))
(let ((dtx (truncate (- (/ (* *shooter-speed* dx) dist) x-speed)))
(dty (truncate (- (/ (* *shooter-speed* dy) dist) y-speed))))
(incf x-speed (limit dtx *shooter-thrust*))
(incf y-speed (limit dty *shooter-thrust*)))
(when (zerop (random 4))
(send window :make-bullet
self x-pos y-pos nil 0
(+ (truncate (/ (* *shooter-bullet-speed* dx) dist)) x-speed)
(+ (truncate (/ (* *shooter-bullet-speed* dy) dist)) y-speed)
*shooter-bullet-life* 3))))))
(defmethod (shooter :kill-bullet) ()
(setq victim nil))
(defmethod (shooter :after :collide) (ignore)
(setq victim nil))
(defflavor warper
(damage)
(moving-object)
:gettable-instance-variables
:settable-instance-variables
(:default-init-plist
:damage -30))
(defmethod (warper :before :reset) ()
(setq x-pos (screen2game (+ 10 (* -20 (random 2)) (ash width -1))))
(setq y-pos (screen2game (+ 50 (random (- height 100)))))
(setq x-speed 0)
(setq y-speed 0))
(defmethod (warper :before :draw) ()
(setq char (+ 60 (logand (ash (time) -3) 1))))
(defmethod (warper :before :tick) ()
(when alive-p
(when (zerop (random 7))
(setq y-speed (limit (+ y-speed (* *warper-thrust* (- (* (random 2) 2) 1)))
*warper-speed*))
(setq x-speed (limit (+ x-speed (* *warper-thrust* (- (* (random 2) 2) 1)))
*warper-speed*)))
(when *warper-gravity*
(loop for player in (send window :players)
for dx = (- (send player :x-pos) x-pos)
for dy = (- (send player :y-pos) y-pos)
for dist = (max (sqrt (+ (* dx dx) (* dy dy))) 1)
for power = (* (expt (/ (- (screen2game 1500) dist)
(coerce (screen2game 1500) 'float)) 7)
.7 2048)
when (send player :alive-p) do
(send player :add-vector
(- (truncate (/ (* power dx) dist)))
(- (truncate (/ (* power dy) dist))))))))
(defmethod (warper :collide) (player)
(send self :collide-sound player)
(send player :warp nil)
(send player :change-shields damage))
(defflavor healer
()
(moving-object)
)
(defmethod (healer :before :reset) ()
(setq x-speed 0)
(setq y-speed 0)
(setq x-pos (screen2game (+ 10 (* -20 (random 2)) (ash width -1))))
(setq y-pos (screen2game (+ 50 (random (- height 100))))))
(defmethod (healer :before :tick) ()
(when (and alive-p (zerop (random 5)))
(when (and (not (eq *crystals* :none)) (zerop (random 50)))
(send window :make-crystal x-pos y-pos))
(setq y-speed (limit (+ y-speed (* *healer-thrust* (- (* (random 2) 2) 1))) *healer-speed*))
(setq x-speed (limit (+ x-speed (* *healer-thrust* (- (* (random 2) 2) 1))) *healer-speed*))))
(defmethod (healer :before :draw) ()
(setq char (+ 48 (logand (ash (time) -2) 3))))
(defmethod (healer :collide) (player)
(send self :collide-sound player (+ 200 (* (send player :number) 600)))
(send player :change-shields 5))
(defflavor crystal
((bonus)
(bonus-string)
(time-count))
(moving-object)
(:default-init-plist
:size 30)
:gettable-instance-variables
:settable-instance-variables
:inittable-instance-variables)
(defun random-crystal-bonus ()
(case *crystals*
(:points (+ (random 40)
(case (random 20)
(0 (random 100))
(1 (random 50))
(t 10))))
(:shields (1+ (random 50)))))
(defmethod (crystal :before :reset) ()
(setq alive-p nil)
(setq char 18)
(setq bonus (random-crystal-bonus))
(setq bonus-string (format nil "~d" bonus))
(setq x-speed (screen2game (- (random 20) 10)))
(setq y-speed (screen2game (- (random 20) 10)))
(setq time-count (+ 20 (random 300))))
(defmethod (crystal :collide) (player)
(when (eq alive-p t)
(send self :collide-sound player 2000)
(send self :erase)
(setq char 0)
(setq x-speed 0
y-speed 0)
(setq alive-p 'touched)
(case *crystals*
(:points
(send player :set-score (+ bonus (send player :score))))
(:shields
(send player :change-shields bonus)))))
(defmethod (crystal :after :tick) ()
(when alive-p
(case alive-p
(touched
(setq alive-p 'waiting
time-count 5))
(waiting
(when (zerop (decf time-count))
(setq alive-p 'show-bonus time-count 20 )))
(show-bonus
(w:prepare-sheet (window)
(send window :string-out-explicit bonus-string
(- (game2screen x-pos) *bsize/2*)
(- (game2screen y-pos) *bsize/2*)
width height fonts:courier w:alu-ior))
(when (zerop (decf time-count))
(setq alive-p 'dead)))
(dead
(w:prepare-sheet (window)
(send window :string-out-explicit bonus-string
(- (game2screen x-pos) *bsize/2*)
(- (game2screen y-pos) *bsize/2*)
width height fonts:courier w:alu-andca))
(send self :die))
(t
(when (and (> bonus 100) (zerop (ldb (byte 1 1) time-count)))
(send self :erase))
(when (zerop (decf time-count))
(setq alive-p 'dead)
(send self :die)))
)))
(defflavor graviton
()
(moving-object))
(defmethod (graviton :before :reset) ()
(setq x-speed 0
y-speed 0)
(setq x-pos (screen2game (ash width -1))
y-pos (screen2game (ash height -1))))
(defmethod (graviton :before :draw) ()
(setq char (+ 44 (if (eq *gravity* :repel)
(logand (lsh (time) -2) 3)
(logand (- (lsh (time) -2)) 3)))))
(defmethod (graviton :warp) (ignore)
())
(defmethod (graviton :collide) (player)
(ignore player))
(defflavor space-war-window
((players nil)
(bullets nil)
(crystals nil)
(objects nil)
num-objects
(collision-array nil)
(gravity-array nil)
alive
stats-window
end-count
angle-count
backup-array
)
(w:process-mixin
w:select-mixin
w:graphics-mixin
w:stream-mixin
w:borders-mixin
w:delay-notification-mixin
w:minimum-window)
(:default-init-plist
:blinker-p nil
:save-bits t
:font-map '(fonts:medfnt))
(:settable-instance-variables stats-window end-count)
:gettable-instance-variables)
(defmethod (space-war-window :after :init) (&rest ignore)
(setq w:process (w:make-process "Space War"))
(process-preset w:process self :loop)
(send w:process :run-reason self)
(loop for i from 2 downto 1 do
(push (make-instance 'player
:number i
:char 64
:window self)
players))
(send self :setup))
(defmethod (space-war-window :setup) ()
(setq bullets '())
(setq crystals nil)
(setq objects (copy-list players))
(loop for i from 0 below *max-floaters* do
(push (make-instance 'floater
:char 1
:window self)
objects))
(loop for i from 0 below *max-shooters* do
(push (make-instance 'shooter
:char 6
:window self)
objects))
(loop for i from 0 below *max-warpers* do
(push (make-instance 'warper
:char 5
:window self)
objects))
(loop for i from 0 below *max-healers* do
(push (make-instance 'healer
:char 48
:window self)
objects))
(push (make-instance 'graviton :char 44 :window self) objects)
)
(defsubst random-limit (min max)
(if (= min max)
min
(+ min (random (1+ (- max min))))))
(defmacro draw-star ()
`(w:prepare-sheet (self)
(let ((x (+ (w:sheet-inside-left)
(random (w:sheet-inside-width))))
(y (+ (w:sheet-inside-top)
(random (w:sheet-inside-height)))))
(setf (aref w:screen-array y x) 1))))
(defmethod (space-war-window :make-arrays) ()
(setq backup-array (make-array (list w:height (dpb 0 (byte 5 0) (+ w:width 31))) :type 'art-1b))
(setq collision-array (make-array (list (+ 4 (ash w:height *collision-grain*))
(+ 4 (ash w:width *collision-grain*)))
:type 'art-1b))
(setq gravity-array (make-array (list (+ 4 (ash w:height *gravity-grain*))
(+ 4 (ash w:width *gravity-grain*))
2)
:type 'art-fix))
(loop with x-mid = (ash (array-dimension gravity-array 1) -1)
and y-mid = (ash (array-dimension gravity-array 0) -1)
for y from 0 below (array-dimension gravity-array 0) do
(loop for x from 0 below (array-dimension gravity-array 1)
for dx = (- x x-mid)
for dy = (- y y-mid)
for dist = (sqrt (+ (square dx) (square dy)))
for power = (max (* dist dist dist) 20)
do
(setf (aref gravity-array y x 0)
(truncate (/ (ash dy 15) power)))
(setf (aref gravity-array y x 1)
(truncate (/ (ash dx 15) power))))))
(defmethod (space-war-window :y-gravity) (x y)
(aref gravity-array
(+ 2 (ash (game2screen y) *gravity-grain*))
(+ 2 (ash (game2screen x) *gravity-grain*))
0))
(defmethod (space-war-window :x-gravity) (x y)
(aref gravity-array
(+ 2 (ash (game2screen y) *gravity-grain*))
(+ 2 (ash (game2screen x) *gravity-grain*))
1))
(defmethod (space-war-window :reset) ()
(tv:sib-sound-bit :off)
(unless (and collision-array gravity-array)
(send self :make-arrays))
(send self :clear-screen)
(send stats-window :clear-screen)
(setq end-count nil)
(setq angle-count 0)
(setq alive 2)
(setq num-objects 0)
(setq *gravity*
(if (eq *gravity-choice* :random)
(nth (random 3) '(:attract :repel :none))
*gravity-choice*))
(setq *edge-action*
(if (eq *edge-action-choice* :random)
(nth (random 2) '(:bounce :go-through))
*edge-action-choice*))
(let ((table `((floater ,(random-limit *min-floaters* *max-floaters*))
(shooter ,(random-limit *min-shooters* *max-shooters*))
(warper ,(random-limit *min-warpers* *max-warpers*))
(healer ,(random-limit *min-healers* *max-healers*))
(graviton ,(if (eq *gravity* :none) 0 1)))))
(loop for object in objects
for lookup = (assoc (type-of object) table) do
(when lookup
(if (zerop (second lookup))
(send object :set-alive-p nil)
(progn
(decf (second lookup))
(send self :alloc-object object)
(send object :set-alive-p t))))
(send object :reset)))
(send stats-window :clear-screen)
(loop for player in players do
(send self :alloc-object player)
(send player :draw-score)
(send player :change-shields *max-shields*))
(dotimes (i 1000)
(draw-star)))
(defmethod (space-war-window :alloc-object) (object)
(let ((i (position object objects)))
(when (> i num-objects)
(let ((x (nth i objects)))
(setf (nth i objects) (nth num-objects objects))
(setf (nth num-objects objects) x)))
(incf num-objects)))
(defmethod (space-war-window :dealloc-object) (object)
(let ((i (position object objects)))
(decf num-objects)
(when (< i num-objects)
(let ((x (nth i objects)))
(setf (nth i objects) (nth num-objects objects))
(setf (nth num-objects objects) x)))))
(defmethod (space-war-window :before :deselect) (&rest ignore)
(tv:sib-sound-bit :off))
(defmethod (space-war-window :mark) (w h x y)
(let ((w/2 (ash w -1))
(h/2 (ash h -1)))
(unless (zerop alive)
(loop for x1 from (ash (- x w/2) *collision-grain*) to (ash (+ x w/2) *collision-grain*) do
(loop for y1 from (ash (- y h/2) *collision-grain*) to (ash (+ y h/2) *collision-grain*) do
(setf (aref collision-array (+ y1 2) (+ x1 2)) 1))))))
(defmethod (space-war-window :loop) (&aux old-time)
(send self :reset)
(do-forever
(send self :get-keys)
(if (send self :self-or-substitute-selected-p)
(progn
(setq old-time (time:fixnum-microsecond-time))
(tv:sib-sound-bit :on)
(process-allow-schedule)
(tv:do-sound (tv:volume 1 15))
(tv:do-sound (tv:volume 2 15))
(unless end-count
(tv:do-sound (tv:volume 3 15)))
(send self :get-input)
(unless (zerop alive)
(tv:%draw-rectangle (array-dimension collision-array 1)
(array-dimension collision-array 0)
0 0 w:erase collision-array))
(loop for object in objects
for i from 0 below num-objects do
(send object :tick))
(when *cloak-p*
(loop for player in players do
(send player :auto-cloak)))
(unless (zerop alive)
(send self :detect-collisions))
(draw-star)
(when (< (time-difference (time:fixnum-microsecond-time) old-time) 25000)
(process-sleep 1))
(setq angle-count (logand (1+ angle-count) 255))
(when end-count
(tv:do-sound (tv:noise 1 2))
(tv:do-sound (tv:volume 3 (- 5 (floor (* end-count 5) *end-life*))))
(when (<= (decf end-count) 0)
(catch 'reset
(send self :end-game)))))
(sleep 1))))
(defmethod (space-war-window :warp-angle) ()
(ash angle-count -3))
(defmethod (space-war-window :get-keys) ()
(loop for char = (send self :tyi-no-hang) do
(unless char
(return nil))
(when *cloak-p*
(loop for i from 0 below 2
for player in players do
(when (and (not (send player :auto-move)) (= char (fifth (nth i *keys*))))
(send player :toggle-cloak))))
(when (= char #\help)
(send self :help))
(when (= char #\space)
(tv:sib-sound-bit :off)
(send self :tyi))
(when (= char #\f1)
(control-panel)
(send self :setup)
(send self :reset))
(when (= char #\f2)
(define-keys))
(when (= char #\end)
(send (car players) :set-score 0)
(send (cadr players) :set-score 0)
(send self :reset))
(when (or (= char #\1) (= char #\2))
(send (nth (- (char-int char) 49) players)
:set-auto-move
(not (send (nth (- (char-int char) 49) players) :auto-move)))
(send (car players) :set-score 0)
(send (cadr players) :set-score 0)
(send self :reset))))
(defmethod (space-war-window :end-game) (&aux winner)
(loop for player in players do
(when (send player :alive-p)
(setq winner player)))
(tv:do-sound (tv:volume 1 15))
(tv:do-sound (tv:volume 2 15))
(tv:do-sound (tv:volume 3 15))
(when winner
(tv:do-sound (tv:tone 0 (+ 200 (* (send winner :number) 600))))
(let ((x1 (- (ash w:width -1) 100))
(x2 (+ (ash w:width -1) 70))
(y1 (- (ash w:height -1) 50))
(y2 (+ (ash w:height -1) 50)))
(send self :string-out-explicit "Points for win:" x1 y1 nil nil fonts:medfnt w:normal)
(loop for i from 20 to 700 by 20 do
(send self :get-keys)
(unless end-count
(throw 'reset nil))
(process-sleep 2)
(tv:do-sound (tv:volume 0 2))
(send self :set-cursorpos x2 y1)
(send self :clear-string "00000")
(send winner :set-score (+ (send winner :score) 20))
(format self "~4d" i)
(tv:do-sound (tv:volume 0 15)))
(send self :string-out-explicit " Shield bonus:" x1 y2 nil nil fonts:medfnt w:normal)
(loop for i from 5 to (send winner :shields) by 5 do
(send self :get-keys)
(unless end-count
(throw 'reset nil))
(process-sleep 2)
(tv:do-sound (tv:volume 0 2))
(send self :set-cursorpos x2 y2)
(send self :clear-string "00000")
(send winner :change-shields -5)
(send winner :set-score (+ (send winner :score) 10))
(format self "~4d" (ash i 1))
(tv:do-sound (tv:volume 0 15)))
(sleep 2)))
(send self :reset))
(defmethod (space-war-window :detect-collisions) ()
(loop for player in players do
(when (and (not (send player :cloak))
(send self :collidep player))
(loop for object in objects
for i from 0 below num-objects
when (and (send object :alive-p) (not (typep object 'player)))
do
(when (send player :collidep object)
(send object :collide player)))))
(when (and (not (or (send (car players) :cloak)
(send (cadr players) :cloak)))
(send (cadr players) :alive-p)
(send (car players) :collidep (cadr players)))
(send (car players) :collide (cadr players))))
(defmethod (space-war-window :collidep) (player)
(plusp (aref collision-array
(+ 2 (ash (game2screen (send player :y-pos)) *collision-grain*))
(+ 2 (ash (game2screen (send player :x-pos)) *collision-grain*)))))
(defmethod (space-war-window :get-input) ()
(loop for player-num from 0
for player in players
for pkeys in *keys*
when (and (send player :alive-p)
(not (send player :auto-move))) do
(when (w:key-state (car pkeys))
(send player :turn-left))
(when (w:key-state (second pkeys))
(send player :turn-right))
(when (w:key-state (third pkeys))
(send player :thrust))
(when (w:key-state (fourth pkeys))
(send player :fire))))
(defmethod (space-war-window :make-bullet) (owner x y dir speed x-speed y-speed life char)
(let ((bullet (or (find-if #'(lambda (x)
(not (send x :alive-p)))
bullets)
(let ((b (make-instance 'bullet
:char char
:window self)))
(push b objects)
(push b bullets)
b))))
(send self :alloc-object bullet)
(send bullet :set-char char)
(send bullet :set-alive-p t)
(send bullet :set-owner owner)
(send bullet :set-x-speed (+ x-speed
(if dir (ash (* speed (aref *cos* dir)) -10)
0)))
(send bullet :set-y-speed (+ y-speed
(if dir (ash (* speed (aref *sin* dir)) -10)
0)))
(send bullet :set-x-pos x)
(send bullet :set-y-pos y)
(send bullet :set-time-left life)
(send bullet :draw)))
(defmethod (space-war-window :make-crystal) (x y)
(let ((crystal (or (find-if #'(lambda (x)
(not (send x :alive-p)))
crystals)
(let ((c (make-instance 'crystal
:window self)))
(push c objects)
(push c crystals)
c))))
(send self :alloc-object crystal)
(send crystal :reset)
(send crystal :set-alive-p t)
(send crystal :set-x-pos x)
(send crystal :set-y-pos y)
(send crystal :draw)))
(defmethod (space-war-window :blow-up) (x y)
(decf alive)
(tv:do-sound (tv:volume 0 15))
(tv:do-sound (tv:volume 1 15))
(tv:do-sound (tv:volume 2 15))
(tv:do-sound (tv:noise 1 2))
(tv:do-sound (tv:volume 3 0))
(loop for i from 0 below 32 by 4 do
(send self :make-bullet nil x y i *fragment-speed* 0 0 *fragment-life* 9))
(loop for i from 2 below 32 by 4 do
(send self :make-bullet nil x y i (ash *fragment-speed* -1) 0 0 *fragment-life* 9))
(setq end-count *end-life*))
(defmethod (space-war-window :after :change-of-size-or-margins) (&rest ignore)
(loop for object in objects do
(send object :set-width w:width)
(send object :set-height w:height)
(send object :set-alive-p nil))
(send self :make-arrays)
(setq end-count 0))
(defflavor space-war-stats
()
(w:graphics-mixin w:stream-mixin w:borders-mixin w:minimum-window)
(:default-init-plist
:font-map '(fonts:medfnt)
:save-bits t
:blinker-p nil))
(defmacro help-line (char desc)
`(progn
(setq w:cursor-x (- (lsh w:width -1) 150))
(format self "~:@C" ,char)
(setq w:cursor-x (lsh w:width -1))
(send self :string-out ,desc)
(incf w:cursor-y 17)))
(defmethod (space-war-window :help) ()
(w:bitblt w:normal w:width w:height w:screen-array 0 0 backup-array 0 0)
(loop for object in objects
for i from 0 below num-objects
when (send object :alive-p) do
(send object :erase))
(send self :string-out-centered-explicit
"Space War" (tv:sheet-inside-left) (floor w:height 10) (tv:sheet-inside-right)
(tv:sheet-inside-right) fonts:43vxms)
(send self :string-out-centered-explicit
"Commands" (tv:sheet-inside-left) (+ (floor w:height 10) 50) (tv:sheet-inside-right)
(tv:sheet-inside-right) fonts:43vxms)
(send self :set-cursorpos 0 (floor w:height 3))
(help-line #\end "Reset game")
(help-line #\space "Pause game")
(help-line #\f1 "Change game parameters")
(help-line #\f2 "Edit command keys")
(help-line #\1 "Toggle auto for player 1")
(help-line #\2 "Toggle auto for player 2")
(format self "~%")
(loop for player-num from 1
for pkeys in *keys* do
(loop for i from 0
for k in pkeys do
(help-line (nth i pkeys) (format nil "Player #~d ~a" player-num (nth i *key-names*))))
(format self "~%"))
(send self :tyi)
(w:bitblt w:normal w:width w:height backup-array 0 0 w:screen-array 0 0))
(defflavor space-war-frame
()
(w:select-mixin
w:alias-for-inferiors-mixin
w:inferiors-not-in-select-menu-mixin
w:bordered-constraint-frame-with-shared-io-buffer)
(:default-init-plist
:panes
'((stats-pane space-war-stats)
(play-pane space-war-window))
:constraints
'((main . ((stats-pane play-pane)
((stats-pane 20))
((play-pane :even)))))))
(defmethod (space-war-frame :after :init) (&rest ignore)
(send self :set-selection-substitute (send self :get-pane 'play-pane))
(send self :set-configuration 'main)
(send (send self :get-pane 'play-pane)
:set-stats-window
(send self :get-pane 'stats-pane)))
(w:add-system-key #\w 'space-war-frame "2Space war*" t)
(compile-flavor-methods space-war-frame space-war-stats space-war-window
floater shooter healer warper crystal
bullet player moving-object)