|
;;;; Trek |
|
;;;; |
|
;;;; Original BASIC version is |
|
;;;; http://www.dunnington.u-net.com/public/startrek/startrek.txt |
|
;;;; (some information in http://www.dunnington.u-net.com/public/startrek/) |
|
;;;; |
|
;;;; Rewritten in Common Lisp by Shozo TAKEOKA ([email protected]) |
|
;;;; http://www.takeoka.org/~take/ |
|
;;;; 2007/FEB/12 CL Ver.1.2.2 |
|
;;;; 2007/JAN/30 CL Ver.1.2.1 |
|
;;;; 2006/DEC/23 CL Ver.1.2 |
|
;;;; 2006/DEC/21 CL Ver.1.1 |
|
;;;; 2006/OCT/09 CL Ver.1 |
|
;;;; |
|
;;;; Revised Common Lisp version by Nobuhiko FUNATO ([email protected]) |
|
;;;; 2021/DEC/13 |
|
;;;; |
|
|
|
;;; In the following comment description, |
|
;;; "the PREV-VER", "FORMER", and "FORMERLY" refer to Mr. Takeoka's code. |
|
;;; (they are annotated FIXED or CHANGED in some cases) |
|
|
|
;;; FIXME/TODO/NIY |
|
;;; + one FIXME remained |
|
|
|
;;(pushnew :test-trek *features*) |
|
|
|
;;;=================================================================== |
|
;;; utilities |
|
|
|
;;; common utilities |
|
|
|
(defmacro fst (f) `(multiple-value-bind (it .i.) ,f (declare (ignore .i.)) it)) |
|
(defmacro snd (f) `(multiple-value-bind (.i. it) ,f (declare (ignore .i.)) it)) |
|
|
|
(defun aref* (a ixs) (apply #'aref a ixs)) |
|
(defun aset* (a v ixs) (setf (apply #'aref a ixs) v)) |
|
|
|
(defmacro aif (tst thn &optional els) `(let ((it ,tst)) (if it ,thn ,els))) |
|
(defmacro awhen (tst &body body) `(let ((it ,tst)) (when it ,@body))) |
|
(defmacro aprog1 (f &body fs) `(let ((it ,f)) ,@fs it)) |
|
|
|
(defmacro and-let* (bindings . body) ; recommended to use it instead of AAND |
|
(labels ((expand (bs bdy) |
|
(cond ((null bs) |
|
;; () |
|
`(progn ,@bdy)) |
|
((symbolp (car bs)) |
|
;; bound-variable |
|
`(if ,(car bs) ,(expand (cdr bs) bdy))) |
|
((and (consp (car bs)) (symbolp (caar bs)) (null (cddar bs))) |
|
;; (variable expression) |
|
`(let (,(car bs)) (if ,(caar bs) ,(expand (cdr bs) bdy)))) |
|
((and (consp (car bs)) (null (cdar bs))) |
|
;; (expression), i.e. a variable is abbreviated |
|
`(if ,(caar bs) ,(expand (cdr bs) bdy))) |
|
(t (error "and-let*"))))) |
|
(expand bindings body))) |
|
|
|
;; see stackoverflow.com/questions/2078490/lisp-format-and-force-output |
|
(defun flush-stdout () (finish-output NIL)) |
|
(defun read-with-prompt (&optional prompt) |
|
(let ((st t)) ; usually *query-io* but here adapt to the whole |
|
(when prompt |
|
(format st prompt) |
|
(flush-stdout)) |
|
(read st))) |
|
|
|
(defun read-input (prompt &key (restart-format "Input again") checker) |
|
(flet ((fn (x) (if (funcall (or checker #'identity) x) x))) |
|
(loop |
|
(with-simple-restart (try-again restart-format) |
|
(awhen (funcall #'fn (read-with-prompt prompt)) |
|
(return it)))))) |
|
|
|
(defmacro with-accessors+ (slot-entries form . body) |
|
(flet ((canonicalize-slot-entry (se) (if (symbolp se) (list se se) se))) |
|
`(with-accessors ,(mapcar #'canonicalize-slot-entry slot-entries) ,form |
|
,@body))) |
|
|
|
;;; somewhat local utilities |
|
|
|
(defun round-off-at-nth-dp (n fv &aux (k (expt 10 (1- n)))) |
|
(assert (and (integerp n) (plusp n))) |
|
(/ (floor (* k fv)) k)) |
|
;(defun round-off-at-3 (fv) (* .01 (floor (* 100 fv)))) |
|
(defun round-off-at-3rd-dp (fv) (round-off-at-nth-dp 3 fv)) |
|
(defun round-off-at-2nd-dp (fv) (round-off-at-nth-dp 2 fv)) |
|
(defun round-with-offset (fv ofs) (floor (+ fv ofs))) ; -> int |
|
(defun round-to-nearest-int (fv) (round-with-offset fv 0.5)) ; -> int |
|
(defun 2d-distance (dx dy) (sqrt (+ (* dx dx) (* dy dy)))) ; -> float |
|
(defun clip-int (x minval maxval) (max minval (min maxval x))) |
|
(defun perturbation-delta (d) (- (random (1+ (* 2 d))) d)) |
|
(defun perturb (v d) (+ v (perturbation-delta d))) |
|
(defun rand8 () (random 8)) |
|
(defun msg (fmt &rest args) (apply #'format t fmt args) (flush-stdout)) |
|
|
|
;;;=================================================================== |
|
;;; common definitions and data structures |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; configurable constants and parameters |
|
|
|
;; klingon |
|
(defconstant +max-n-klingon+ 4) ; who knows the array size is valid |
|
(defconstant +mid-klingon-energy+ 200) |
|
|
|
;; enterprise |
|
(defconstant +full-energy+ 3000) |
|
(defconstant +full-torpedo+ 10) ; max # of torpedoes |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; universe |
|
;;; |
|
|
|
;;; |
|
;;; globals of global |
|
;;; |
|
|
|
(defvar *time* 0) ; current time, aka stardate |
|
(defvar *time-0* 0) ; initial time (session local param) |
|
(defvar *t-period* 0) ; given mission period (session local param) |
|
|
|
(defvar *star-total* 0) ; # of star (just for reference after init.) |
|
(defvar *base-total* 0) ; rest # of starbase |
|
(defvar *klingon-total* 0) ; rest # of klingon |
|
(defvar *klingon-total-0* 0) ; initial klingon # (session local param) |
|
|
|
(defvar *klingon-turn-p* nil) ; whether turn of klingon or not |
|
|
|
(defvar *ep* nil) ; enterprise (singleton) |
|
(defvar *sec* nil) ; current sector where enterprise resides |
|
|
|
;;; |
|
;;; time and date related APIs |
|
;;; |
|
|
|
(defun proceed-time (&optional (t1 1)) |
|
(incf *time* t1)) |
|
|
|
(defun time-proceed-p () (< *time-0* *time*)) |
|
(defun stardate () *time*) |
|
(defun given-period () *t-period*) |
|
(defun end-time () (+ *time-0* *t-period*)) |
|
(defun rest-period () (- (end-time) *time*)) |
|
(defun mission-timeout-p () (< (end-time) *time*)) ; or (minusp (rest-period)) |
|
|
|
(defun efficiency-rating (&optional (n-klingon *klingon-total-0*)) |
|
(let ((x (/ n-klingon (- *time* *time-0*)))) |
|
(* x x 1000))) |
|
|
|
;;; |
|
;;; quad-name, etc |
|
;;; |
|
|
|
;;; (0,0)-(0,3) antares I II III IV (0,4)-(0,7) sirius I II III IV |
|
;;; (1,0)-(1,4) rigel I II III IV (1,4)-(1,7) deneb I II III IV |
|
;;; (2,0)-(2,4) procyon I II III IV (2,4)-(2,7) capella I II III IV |
|
;;; (3,0)-(3,4) vega I II III IV (3,4)-(3,7) betelgeuse I II III IV |
|
;;; (4,0)-(4,4) canopus I II III IV (4,4)-(4,7) aldebaran I II III IV |
|
;;; (5,0)-(5,4) altair I II III IV (5,4)-(5,7) regulus I II III IV |
|
;;; (6,0)-(6,4) sagittarius I II III IV (6,4)-(6,7) alcturus I II III IV |
|
;;; (7,0)-(7,4) pollux I II III IV (7,4)-(7,7) spica I II III IV |
|
|
|
;; really many 8s are hard-coded, such as (RAND8), (FLOOR X 8), ... |
|
(defconstant +quad-xdim+ 8) |
|
(defconstant +quad-ydim+ 8) |
|
(defvar +quad-dims+ (list +quad-xdim+ +quad-ydim+)) |
|
|
|
(defvar +qname1+ #("ANTARES" "RIGEL" "PROCYON" "VEGA" |
|
"CANOPUS" "ALTAIR" "SAGITTARIUS" "POLLUX")) |
|
(defvar +qname2+ #("SIRIUS" "DENEB" "CAPELLA" "BETELGEUSE" |
|
"ALDEBARAN" "REGULUS" "ARCTURUS" "SPICA")) |
|
(defvar +suffix+ #(" I" " II" " III" " IV")) ; sector suffix |
|
|
|
(defun valid-coord-xy-p (x y) |
|
(and (<= 0 x 7) (<= 0 y 7))) |
|
(defun valid-coord-p (c) |
|
(and (consp c) (consp (cdr c)) (null (cddr c)) |
|
(apply #'valid-coord-xy-p c))) |
|
(defun read-coord (prompt) |
|
(read-input prompt :checker #'valid-coord-p)) |
|
(defun coord= (qc1 qc2) (equal qc1 qc2)) |
|
|
|
(defun quad-name (x y &optional (with-suffix-p t)) |
|
(assert (valid-coord-xy-p x y)) |
|
(let ((qname (svref (if (< y 4) +qname1+ +qname2+) x)) |
|
(suffix (if with-suffix-p (svref +suffix+ (mod y 4))))) |
|
(concatenate 'string qname suffix))) |
|
|
|
;;; |
|
;;; conversion routines among some coordinate systems |
|
;;; |
|
|
|
;;; top-level APIs are p2p-course (FORMER calc-p2p) and |
|
;;; course-to-vec (FORMER cal-vec) |
|
|
|
(defun cartesian-to-polar (dx dy) |
|
(let ((rho (sqrt (+ (* dx dx) (* dy dy)))) |
|
(theta (atan dy dx))) ; CL spec specifies that -π<θ and θ<=π hold. |
|
(values rho theta))) |
|
|
|
(defun polar-to-cartesian (rho theta) |
|
(let ((dx (* rho (cos theta))) |
|
(dy (* rho (sin theta)))) |
|
(values dx dy))) |
|
|
|
(defun course-to-polar-theta (course &aux theta) |
|
(assert (and (<= 0 course) (< course 8))) |
|
(when (<= 0 course 2) (incf course 8)) |
|
(cond ((<= 6 course) |
|
;; map 10〜6 to π〜0 |
|
;; (i.e. map 6〜8 to π〜π/2 and 0〜2 to π/2〜0) |
|
(setq theta (/ (* (- 10 course) pi) 4)) |
|
(assert (<= 0 theta pi))) |
|
(t |
|
;; map 6〜2 to -π〜0 |
|
(setq theta (- (/ (* (- course 2) pi) 4))) |
|
(assert (< (- pi) theta 0)))) |
|
theta) |
|
|
|
(defun polar-theta-to-course (theta &aux course) |
|
;; assuming -π<θ and θ<=π to match CL spec |
|
(assert (and (< (- pi) theta) (<= theta pi))) |
|
(cond ((minusp theta) |
|
;; map -π〜0 to 6〜2 |
|
(setq theta (abs theta)) |
|
(setq course (+ 2 (/ (* 4 theta) pi))) |
|
(assert (< 2 course 6))) |
|
(t |
|
;; map π〜π/2 to 6〜8, and π/2〜0 to 0〜2 |
|
(setq course (- 10 (/ (* 4 theta) pi))) |
|
(when (<= 8 course) (decf course 8)) |
|
(assert (or (<= 0 course 2) (and (<= 6 course) (< course 8)))))) |
|
course) |
|
|
|
(defun polar-to-vec (rho theta) |
|
(multiple-value-bind (dx dy) (polar-to-cartesian rho theta) |
|
(values (- dy) dx))) |
|
|
|
(defun vec-to-polar (dx dy) |
|
(cartesian-to-polar dy (- dx))) |
|
|
|
(defun vec-to-distance/course (dx dy) |
|
(multiple-value-bind (rho theta) (vec-to-polar dx dy) |
|
(values rho (polar-theta-to-course theta)))) |
|
|
|
(defun scale-dx/dy (course dx dy) |
|
;; in the answer, one has length 1, and the other has shorter length than 1 |
|
(flet ((course-to-octant (c) |
|
(cond ((< c 1) 'zero) ((< c 3) 'one-or-two) |
|
((< c 5) 'three-or-four) ((< c 7) 'five-or-six) |
|
(t 'seven)))) |
|
(ecase (course-to-octant course) |
|
((seven zero) (values (/ dx (abs dy)) +1)) |
|
(one-or-two (values +1 (/ dy (abs dx)))) |
|
(three-or-four (values (/ dx (abs dy)) -1)) |
|
(five-or-six (values -1 (/ dy (abs dx))))))) |
|
|
|
(defun course-to-dx/dy (course &optional distance) |
|
(assert (and (<= 0 course) (< course 8))) ; initially got by INPUT-COURSE |
|
(let ((theta (course-to-polar-theta course))) |
|
(if distance |
|
(polar-to-cartesian distance theta) |
|
(multiple-value-bind (dx dy) (polar-to-cartesian 1.0 theta) |
|
(scale-dx/dy course dx dy))))) |
|
|
|
;; course-to-vec in the PREV-VER uses DDA, but we adopt using |
|
;; trigonometric funcions (apparently simpler than the PREV-VER?) |
|
(defun COURSE-TO-VEC (course &optional distance) ; FORMER cal-vec |
|
(multiple-value-bind (dx dy) (course-to-dx/dy course distance) |
|
(values (- dy) dx))) |
|
|
|
(defun P2P-DISTANCE/COURSE (spos0 spos1) |
|
(destructuring-bind (x0 y0) spos0 |
|
(destructuring-bind (x1 y1) spos1 |
|
(vec-to-distance/course (- x1 x0) (- y1 y0))))) |
|
|
|
(defun P2P-COURSE (spos0 spos1) ; FORMER calc-p2p |
|
(snd (p2p-distance/course spos0 spos1))) |
|
|
|
(defun P2P-DISTANCE (spos0 spos1) |
|
(destructuring-bind (x0 y0) spos0 |
|
(destructuring-bind (x1 y1) spos1 |
|
(2d-distance (- x0 x1) (- y0 y1))))) |
|
|
|
;;; calc-p2p (p2p-course) and cal-vec (course-to-vec) in the PREV-VER |
|
;;; are shown below. |
|
|
|
#+:hoge |
|
(defun calc-p2p (xy0 xy1 &aux |
|
(dx (- (first xy1) (first xy0))) |
|
(dy (- (second xy1) (second xy0)))) |
|
;; so-called DDA |
|
(labels ((calc0 (n dx dy) (- n (/ dy dx))) |
|
(calc1 (n dx dy) (+ n (/ dx dy))) |
|
(calc2 (n dx dy) (calc0 n dx dy)) |
|
(calc3 (n dx dy) (calc1 n dx dy))) |
|
(cond ((and (= dx 0) (= dy 0)) 0) |
|
((and (<= 0 dx) (<= 0 dy)) (if (< (abs dx) (abs dy)) |
|
(calc1 2 dx dy) |
|
(calc2 4 dx dy))) |
|
((and (< dx 0) (<= 0 dy)) (if (< (abs dy) (abs dx)) |
|
(calc0 0 dx dy) |
|
(calc1 2 dx dy))) |
|
((and (< dx 0) (< dy 0)) (if (< (abs dx) (abs dy)) |
|
(calc3 6 dx dy) |
|
(calc0 8 dx dy))) |
|
((and (<= 0 dx) (< dy 0)) (if (< (abs dy) (abs dx)) |
|
(calc2 4 dx dy) |
|
(calc3 6 dx dy)))))) |
|
|
|
#+:hoge |
|
(progn |
|
(defvar +cx+ #(-1 -1 0 1 1 1 0 -1 -1)) |
|
(defvar +cy+ #( 0 1 1 1 0 -1 -1 -1 0)) |
|
(defun cal-vec (course) |
|
(assert (and (<= 0 course) (< course 8))) |
|
(flet ((sub-fn (va) |
|
;; cr is for linear proportional distribution, which is not exact, |
|
;; though probably it's intentional in the original BASIC code |
|
(let* ((ci (floor course)) (cr (- course ci))) |
|
(assert (<= 0 ci 7)) |
|
(+ (svref va ci) |
|
(* cr (- (svref va (1+ ci)) (svref va ci))))))) |
|
(values (sub-fn +cx+) (sub-fn +cy+)))) |
|
) ; progn |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; klingon |
|
;;; |
|
|
|
;; whole klingons holder array (not on the front stage after initialization) |
|
(defvar *klingons* nil) |
|
|
|
(defstruct (klingon (:conc-name kli-)) |
|
spos |
|
(energy 0) ; if plus, the klingon is alive |
|
) |
|
|
|
(defun initialize-klingons () |
|
(setq *klingons* |
|
(aprog1 (make-array +max-n-klingon+) |
|
(map-into it #'make-klingon)))) |
|
|
|
(defun initial-klingon-energy () ; called under initialize-sector |
|
(* +mid-klingon-energy+ |
|
(+ 5 (random 10)) 0.1)) ; multiply a factor from 0.5 to 1.5 |
|
|
|
(defmacro loop-for-klingons ((k &key (all-p nil)) &body body) |
|
`(loop for ,k across *klingons* |
|
when (or ,all-p (plusp (kli-energy ,k))) |
|
do (progn ,@body))) |
|
|
|
(defun find-klingon (fn &key (all-p nil)) |
|
(find-if (lambda (k) |
|
(and (or all-p (plusp (kli-energy k))) |
|
(funcall fn k))) |
|
*klingons*)) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; quadrant |
|
;;; |
|
|
|
;; whole quadrants holder array (not on the front stage after initialization) |
|
(defvar *quadrants* nil) |
|
|
|
(defstruct (quadrant (:conc-name quad-)) |
|
scanned-p ; include whether visit or not -- FORMERLY "visit" |
|
|
|
;; the members below work as default-initargs for SECTOR |
|
;; (cf. INITIALIZE-SECTOR) |
|
(n-klingon 0) |
|
(n-base 0) |
|
(n-star 0) |
|
) |
|
|
|
(defun quadrant-at-xy (x y &optional errp) |
|
(cond ((valid-coord-xy-p x y) |
|
(aref *quadrants* x y)) |
|
(errp |
|
(error "illegal quadrant coord: (~a ~a)" x y)) |
|
(t nil))) |
|
|
|
(defun quadrant-at (spos &optional errp) |
|
(quadrant-at-xy (car spos) (cadr spos) errp)) |
|
|
|
(defun initialize-quadrants () |
|
(setq *klingon-total* 0) |
|
(setq *base-total* 0) |
|
(setq *star-total* 0) |
|
(setq *quadrants* |
|
(aprog1 (make-array +quad-dims+ :initial-element nil) |
|
(loop for i from 0 below +quad-xdim+ do |
|
(loop for j from 0 below +quad-ydim+ |
|
for r = (random 100) |
|
for k = (cond ((> r 98) 3) ((> r 95) 2) ((> r 8) 1) (t 0)) |
|
for b = (cond ((> (random 100) 96) 1) (t 0)) |
|
for s = (1+ (rand8)) |
|
do (progn |
|
(incf *klingon-total* k) |
|
(incf *base-total* b) |
|
(incf *star-total* s) |
|
(setf (aref it i j) |
|
(make-quadrant :n-klingon k |
|
:n-base b |
|
:n-star s)))))))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; enterprise |
|
;;; |
|
|
|
(defstruct (enterprise (:conc-name ep-)) |
|
qcoord ; quadrant where enterprise resides -- FORMER *qx*/*qy* |
|
spos ; position in sector, aka spos -- FORMER *ex*/*ey* |
|
|
|
condi |
|
docked-p |
|
(torpedo 0) |
|
(energy 0) |
|
(shield 0) |
|
damage-arr |
|
|
|
(damage-repair-magic-number 0) ; session local param |
|
) |
|
|
|
(defun ep-total-energy (ep) ; alias pseudo accessor |
|
(+ (ep-shield ep) (ep-energy ep))) |
|
|
|
(defun ep-current-quadrant () |
|
(quadrant-at (ep-qcoord *ep*) t)) |
|
|
|
(defun ep-quad-name (&optional (ep *ep*)) |
|
(apply #'quad-name (ep-qcoord ep))) |
|
|
|
(defun distance-to-klingon (k) |
|
(with-accessors+ (kli-spos) k |
|
(round-to-nearest-int |
|
(p2p-distance kli-spos (ep-spos *ep*))))) |
|
|
|
(defconstant +DAMAGE_ARRAY_SIZE+ 8) |
|
(defconstant +DEV_WARP+ 0) |
|
(defconstant +DEV_SRS+ 1) |
|
(defconstant +DEV_LRS+ 2) |
|
(defconstant +DEV_PHASER+ 3) |
|
(defconstant +DEV_TORPEDO+ 4) |
|
(defconstant +DEV_SHIELD+ 5) |
|
(defconstant +DEV_DAMAGE_REPORT+ 6) |
|
(defconstant +DEV_COMPUTER+ 7) |
|
|
|
(defun damage-of (ix) |
|
(assert (<= 0 ix 7)) |
|
(aref (ep-damage-arr *ep*) ix)) |
|
|
|
(defun (setf damage-of) (v ix) |
|
(assert (<= 0 ix 7)) |
|
(setf (aref (ep-damage-arr *ep*) ix) v)) |
|
|
|
(defvar +device-name+ |
|
#("WARP ENGINES" "SHORT RANGE SENSORS" "LONG RANGE SENSORS" |
|
"PHASER CONTROL" "PHOTON TUBES" "DAMAGE CONTROL" |
|
"SHIELD CONTROL" "LIBRARY-COMPUTER")) |
|
|
|
(defun device-name (ix) |
|
(assert (<= 0 ix 7)) |
|
(svref +device-name+ ix)) |
|
|
|
(defun initialize-enterprise () |
|
(setq *ep* |
|
(make-enterprise |
|
:qcoord (list (rand8) (rand8)) |
|
:spos (list (rand8) (rand8)) |
|
:condi 'GREEN |
|
:docked-p nil |
|
:torpedo +full-torpedo+ |
|
:energy +full-energy+ |
|
:shield 0 |
|
:damage-arr (make-array +DAMAGE_ARRAY_SIZE+ :initial-element 0) |
|
:damage-repair-magic-number (/ (random 50) 100)))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; sector |
|
;;; |
|
|
|
;; transient record for the current quadrant sector |
|
(defstruct (sector (:conc-name "")) |
|
smap ; current sector map -- 8x8 array |
|
(n-klingon_ 0) ; current # of klingon in a sector |
|
(n-base_ 0) ; current # of base in a sector |
|
base-spos_ ; maybe spos -- FORMER *bx*/*by* |
|
) |
|
|
|
;; just re-use code for coord, since spos and coord have same structure |
|
(defun valid-spos-xy-p (x y) (valid-coord-xy-p x y)) |
|
(defun valid-spos-p (spos) (valid-coord-p spos)) |
|
(defun read-spos (prompt) (read-coord prompt)) |
|
(defun spos= (sp1 sp2) (equal sp1 sp2)) |
|
|
|
(defun sec-symbol (i j) |
|
(case (aref (smap *sec*) i j) (S "*") (K "K") (B "B") (E "E") (t "."))) |
|
(defun get-smap (spos &optional (sec *sec*)) (aref* (smap sec) spos)) |
|
(defun set-smap (val spos &optional (sec *sec*)) (aset* (smap sec) val spos)) |
|
(defun n-klingon (&optional (sec *sec*)) (n-klingon_ sec)) |
|
(defun n-base (&optional (sec *sec*)) (n-base_ sec)) |
|
(defun base-spos (&optional (sec *sec*)) (base-spos_ sec)) |
|
(defun (setf n-klingon) (v &optional (sec *sec*)) (setf (n-klingon_ sec) v)) |
|
(defun (setf n-base) (v &optional (sec *sec*)) (setf (n-base_ sec) v)) |
|
(defun (setf base-spos) (v &optional (sec *sec*)) (setf (base-spos_ sec) v)) |
|
|
|
;;; init-sector |
|
|
|
(defun random-empty-spos (sec) |
|
;; we assert that no need to worry as to stuck into an infinite loop |
|
(flet ((empty-spos? (p) (null (get-smap p sec)))) |
|
(loop for spos = (list (rand8) (rand8)) |
|
until (empty-spos? spos) |
|
finally (return spos)))) |
|
|
|
(defun init-sec-klingons (sec n-klingon) |
|
;; at current, 0-3 klingons per quadrant (no case of +max-n-klingon+, i.e. 4) |
|
(assert (<= 0 n-klingon 3)) ; cf. initialize-quadrants |
|
(loop for k across *klingons* |
|
do (setf (kli-energy k) 0)) ; inactivate all as reset |
|
(loop repeat n-klingon |
|
for k across *klingons* |
|
for spos = (random-empty-spos sec) |
|
do (set-smap 'K spos sec) |
|
(setf (kli-spos k) spos |
|
(kli-energy k) (initial-klingon-energy)))) |
|
|
|
(defun init-sec-bases (sec n-base) |
|
(assert (or (= 0 n-base) (= 1 n-base))) ; enough to remember just one base |
|
(loop repeat n-base |
|
for spos = (random-empty-spos sec) |
|
do (set-smap 'B spos sec) |
|
(setf (base-spos sec) spos))) |
|
|
|
(defun init-sec-stars (sec n-star) |
|
(loop repeat n-star |
|
for spos = (random-empty-spos sec) |
|
do (set-smap 'S spos sec))) |
|
|
|
(defun initialize-sector (quad) |
|
(with-accessors+ ((k quad-n-klingon) (b quad-n-base) (s quad-n-star)) quad |
|
(setq *sec* |
|
(aprog1 (make-sector :smap (make-array '(8 8) :initial-element nil) |
|
:n-klingon_ k |
|
:n-base_ b) |
|
;; Place 'E first, i.e. before calling init-sec-xxx |
|
(set-smap 'E (ep-spos *ep*) it) |
|
(init-sec-klingons it k) |
|
(init-sec-bases it b) |
|
(init-sec-stars it s))))) |
|
|
|
;;; klingon-related (delete-klingon / delete-klingon-at / klingon-rand-move) |
|
|
|
(defun delete-klingon (k) |
|
(with-accessors+ (kli-spos kli-energy) k |
|
(msg "*** KLINGON DESTROYED ***~%") |
|
(setf kli-energy 0) |
|
(set-smap nil kli-spos) |
|
(decf (n-klingon)) |
|
(decf *klingon-total*) |
|
(decf (quad-n-klingon (ep-current-quadrant))))) |
|
|
|
(defun delete-klingon-at (spos) |
|
(awhen (find-klingon (lambda (k) (spos= (kli-spos k) spos))) |
|
(delete-klingon it))) |
|
|
|
(defun possible-spos-to-move (spos) |
|
(assert (eq (get-smap spos) 'K)) ; assumption in this context |
|
(labels ((randmove-v (v) (clip-int (perturb v 1) 0 7)) |
|
(randmove-vec (p) (mapcar #'randmove-v p))) |
|
(loop ; possible-spos-to-move may return the current pos for 'K |
|
(let ((new-spos (randmove-vec spos))) |
|
(ecase (get-smap new-spos) |
|
((nil) (return-from possible-spos-to-move new-spos)) |
|
(K (return-from possible-spos-to-move nil)) |
|
((S B E) nil)))))) |
|
|
|
(defun klingon-rand-move (k) |
|
(with-accessors+ (kli-spos) k |
|
(awhen (possible-spos-to-move kli-spos) |
|
(msg "Klingon at ~a moves to ~a~%" kli-spos it) |
|
(set-smap nil kli-spos) |
|
(set-smap 'K it) |
|
(setf kli-spos it)))) |
|
|
|
;;;=================================================================== |
|
;;; commands and command loop |
|
;;; |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; common exit points from command loop |
|
|
|
(defun end-of-mission-silently (rc) |
|
(throw 'game-end rc)) |
|
|
|
(defun end-of-mission (rc) |
|
(msg "THERE WERE ~a KLINGON BATTLE CRUISERS LEFT AT~%" *klingon-total*) |
|
(msg "THE END OF YOUR MISSION.~%") |
|
(throw 'game-end rc)) |
|
|
|
(defun fail-mission (rc) |
|
(msg "IT IS STARDATE ~5,2f.~%" (stardate)) |
|
(end-of-mission rc)) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; short range sensor (command 1) |
|
|
|
(defun base-vicinity-p () |
|
(destructuring-bind (x y) (ep-spos *ep*) |
|
(loop for i from -1 to 1 do |
|
(loop for j from -1 to 1 |
|
for spos = (list (+ x i) (+ y j)) |
|
if (and (valid-spos-p spos) |
|
(eq (get-smap spos) 'B)) |
|
do (return-from base-vicinity-p spos))) |
|
nil)) |
|
|
|
(defun set-condition () |
|
(with-accessors+ (ep-condi ep-docked-p ep-torpedo ep-energy ep-shield) *ep* |
|
(flet ((dock () |
|
(setf ep-docked-p t |
|
ep-condi 'DOCKED |
|
ep-torpedo +full-torpedo+ |
|
ep-energy +full-energy+ |
|
ep-shield 0) |
|
(msg "SHIELDS DROPPED FOR DOCKING PURPOSES.~%"))) |
|
(if (base-vicinity-p) |
|
(dock) |
|
(setf ep-docked-p nil |
|
ep-condi (cond ((plusp (n-klingon)) '*RED*) |
|
((< ep-energy (/ +full-energy+ 10)) 'YELLOW) |
|
(t 'GREEN))))))) |
|
|
|
(defparameter +disp-info-fns+ |
|
;; The PREV-VER does rigid round-off for stardate (CHANGED to use just ~5.2f). |
|
;; Also, ~4.2f for SHIELDS has been changed from ~5.2f in the PREV-VER, |
|
;; in order to print either 0.0 or 10.0 same as 100.0. |
|
(vector |
|
(lambda () (msg "~8@t~19a~5,2f" "STARDATE" (stardate))) |
|
(lambda () (msg "~8@t~19a~a" "CONDITION" (ep-condi *ep*))) |
|
(lambda () (msg "~8@t~19a~a" "QUADRANT" (ep-qcoord *ep*))) |
|
(lambda () (msg "~8@t~19a~a" "SECTOR" (ep-spos *ep*))) |
|
(lambda () (msg "~8@t~19a~a" "PHOTON TORPEDOES" (ep-torpedo *ep*))) |
|
(lambda () (msg "~8@t~19a~5,2f" "TOTAL ENERGY" (ep-total-energy *ep*))) |
|
(lambda () (msg "~8@t~19a~4,2f" "SHIELDS" (ep-shield *ep*))) |
|
(lambda () (msg "~8@t~19a~a" "KLINGONS REMAINING" *klingon-total*)))) |
|
|
|
(defun short-range-sensor-1 () |
|
(msg " +0-1-2-3-4-5-6-7-+") |
|
(dotimes (i 8) |
|
(msg "~% ~a|" i) |
|
(dotimes (j 8) (msg "~a " (sec-symbol i j))) |
|
(msg "|") |
|
(funcall (svref +disp-info-fns+ i))) |
|
(msg "~%")) |
|
|
|
(defun short-range-sensor () |
|
(set-condition) |
|
(when (minusp (damage-of +DEV_SRS+)) |
|
(msg "*** SHORT RANGE SENSORS ARE OUT ***~%") |
|
(return-from short-range-sensor)) |
|
(short-range-sensor-1)) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; enter-quadrant |
|
|
|
(defvar *resume-trek-p*) |
|
|
|
(defun enter-quadrant-1 () |
|
;; in the PREV-VER, set-quad-scanned-p/initialize-sector/short-range-sensor |
|
;; are always done, but the others aren't unless qcoord is valid (CHANGED) |
|
;; -- this is because the assertion below seems to be correct. |
|
(assert (valid-coord-p (ep-qcoord *ep*))) |
|
(let ((q1 (EP-CURRENT-QUADRANT))) |
|
(setf (quad-scanned-p q1) t) ; note: entering means scanning |
|
(unless (zerop (quad-n-klingon q1)) |
|
(msg " COMBAT AREA CONDITION RED ~%")) |
|
(when (<= (ep-shield *ep*) 200) |
|
(msg " SHIELDS DANGEROUSLY LOW ~%")) |
|
(unless *resume-trek-p* |
|
(initialize-sector q1)) |
|
(short-range-sensor))) |
|
|
|
(defun enter-quadrant () |
|
(cond ((time-proceed-p) |
|
;; normally time has proceeded because we come here through NAV |
|
(msg "~%NOW ENTERING ~a QUADRANT . . .~%" (ep-quad-name)) |
|
(enter-quadrant-1)) |
|
(t |
|
;; should be called after initialize-trek for EP-CURRENT-QUADRANT |
|
(msg "YOUR MISSION BEGINS WITH YOUR STARSHIP LOCATED~%") |
|
(msg "IN THE GALACTIC QUADRANT, '~a'.~%" (ep-quad-name)) |
|
(enter-quadrant-1)))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; nav (command 0) |
|
|
|
;;; input-course / input-nav-factor / determine-nav-energy |
|
|
|
(defun input-course (crew) ; shared by NAV and TORPEDO |
|
(flet ((input-course-1 () |
|
(let ((c1 (read-input "COURSE (0-8, -1) "))) |
|
(cond ((not (numberp c1)) nil) |
|
((= c1 -1) nil) |
|
((not (<= 0 c1 8)) |
|
(msg " ~a: 'INCORRECT COURSE DATA, SIR!'" crew) |
|
;; the PREV-VER had been return T below (FIXED) |
|
nil) |
|
(t |
|
;; the PREV-VER had lacked the adjustment for 8 (FIXED) |
|
(if (= c1 8) 0 c1)))))) |
|
(aprog1 (input-course-1) |
|
(assert (or (null it) (and (<= 0 it) (< it 8))))))) |
|
|
|
(defun input-nav-factor () |
|
(let* ((w-damage (damage-of +DEV_WARP+)) |
|
(x (if (< w-damage 0) 0.2 8)) |
|
w1) |
|
(msg "WARP FACTOR (0-~a) " x) |
|
(setq w1 (read-input nil)) |
|
(cond ((not (numberp w1)) nil) |
|
((= w1 0) nil) |
|
((and (< w-damage 0) (< 0.2 w1)) |
|
(msg "WARP ENGINES ARE DAMAGED. MAXIUM SPEED = WARP 0.2") |
|
nil) |
|
((not (<= 0 w1 8)) |
|
(msg " CHIEF ENGINEER SCOTT: 'THE ENGINES WON'T TAKE WARP~a!'" w1) |
|
nil) |
|
(t w1)))) |
|
|
|
(defun determine-nav-energy (w1 &aux (n (round-to-nearest-int (* w1 8)))) |
|
(with-accessors+ (ep-energy ep-shield) *ep* |
|
(cond ((<= n ep-energy) n) |
|
(t |
|
(msg "ENGINEERING: 'INSUFFICIENT ENERGY AVAILABLE~%") |
|
(msg " FOR MANEUVERING AT WARP~a!'~%" w1) |
|
(unless (or (< ep-shield (- n ep-energy)) |
|
(minusp (damage-of +DEV_DAMAGE_REPORT+))) |
|
(msg "DEFLECTOR CONTROL ROOM: ~a UNITS OF ENERGY~%" ep-shield) |
|
(msg " PRESENTLY DEPLOYED TO SHIELDS.")) |
|
;; The PREV-VER returns T -- it must be clerical error of NIL (FIXED) |
|
nil)))) |
|
|
|
;;; klingon-attack / klingon-attack-at-warp |
|
|
|
(defun enterprise-destroyed () |
|
(msg "~2%THE ENTERPRISE HAS BEEN DESTROYED.") |
|
(msg " THE FEDERATION WILL BE CONQUERED.~%") |
|
(fail-mission '+RC_ENTERPRISE_DESTROYED+)) |
|
|
|
(defun hit-by-klingon (h) |
|
(with-accessors+ (ep-shield) *ep* |
|
(unless (plusp (decf ep-shield h)) |
|
(enterprise-destroyed)) |
|
(msg " <SHIELDS DOWN TO ~a UNITS>~%" ep-shield) |
|
(when (and (<= 20 h) |
|
(< 0.02 (/ h ep-shield)) |
|
(<= (random 10) 6)) ; ... and 60% chance |
|
(let ((r1 (rand8))) |
|
(decf (damage-of r1) (+ (/ h ep-shield) (/ (random 50) 100))) |
|
(msg "DAMAGE CONTROL: '~a DAMAGED BY THE HIT'" (device-name r1)))))) |
|
|
|
(defun klingon-attack () |
|
(unless (plusp (n-klingon)) |
|
(return-from klingon-attack)) |
|
(when (ep-docked-p *ep*) |
|
(msg "STARBASE SHIELDS PROTECT THE ENTERPRISE.~%") |
|
(return-from klingon-attack)) |
|
(loop-for-klingons (k) |
|
(with-accessors+ (kli-spos kli-energy) k |
|
(let ((h (floor (* (/ kli-energy (distance-to-klingon k)) |
|
(+ 2 (/ (random 10) 10)))))) |
|
(setf kli-energy (/ kli-energy (+ 3 (/ (random 10) 10)))) |
|
(msg "~a UNIT HIT ON ENTERPRISE FROM SECTOR ~a.~%" h kli-spos) |
|
(hit-by-klingon h))))) |
|
|
|
(defun klingon-attack-at-warp () |
|
(loop-for-klingons (k) (klingon-rand-move k)) |
|
(klingon-attack)) |
|
|
|
;;; repair-for-warp |
|
|
|
(defun repair-for-warp (w1) |
|
(declare (ignore w1)) |
|
;; In the PREV-VER, loop is from 0 to 8, |
|
;; where 0 IS NOT USED and 1-8 corresponds to the current 0-7. |
|
;; Now we only loop for 0-7 (FIXED). |
|
(loop with flag = nil |
|
for i from 0 below +DAMAGE_ARRAY_SIZE+ |
|
do (when (minusp (damage-of i)) |
|
(let ((x (incf (damage-of i)))) |
|
(when (<= 0 x) |
|
(setf (damage-of i) 0) |
|
(when (null flag) |
|
(msg "DAMAGE CONTROL REPORT: ") |
|
(setq flag t)) |
|
(msg "~a REPAIR COMPLETED.~%" (device-name i))))))) |
|
|
|
;;; damage-by-warp |
|
|
|
(defun damage-by-warp () |
|
(when (<= (random 10) 2) ; 20% chance of taking damage |
|
(let* ((damdev (rand8)) |
|
(devnam (device-name damdev)) |
|
(damage-amount |
|
(cond ((< (random 10) 6) |
|
(msg "DAMAGE CONTROL REPORT: ~a DAMAGED~%" devnam) |
|
(- (1+ (/ (random 500) 100)))) |
|
(t |
|
(msg "DAMAGE CONTROL REPORT: ~a STATE OF ~ |
|
REPAIR IMPROVED~%" devnam) |
|
(1+ (/ (random 300) 100)))))) |
|
(incf (damage-of damdev) damage-amount)))) |
|
|
|
;;; nav4 |
|
|
|
(defun dec-energy (n) |
|
(with-accessors+ (ep-energy ep-shield) *ep* |
|
(when (minusp (decf ep-energy (+ n 10))) |
|
(msg "SHIELD CONTROL SUPPLIES ENERGY TO COMPLETE THE MANEUVER.~%") |
|
(setf ep-shield (max 0 (+ ep-shield ep-energy)) |
|
ep-energy 0)))) |
|
|
|
(defun warp-time (w1) |
|
(proceed-time (if (< w1 1) (round-off-at-2nd-dp w1) 1)) |
|
(when (mission-timeout-p) |
|
(fail-mission '+RC_TIMEOUT_BY_WARP+))) |
|
|
|
#+:hoge |
|
(defun old-exit-quad (n x y x1 y1 w1 old-qx old-qy) |
|
(let ((flag nil)) |
|
|
|
(incf x (+ (* 8 (ep-qx *ep*)) (* n x1))) |
|
(incf y (+ (* 8 (ep-qy *ep*)) (* n y1))) |
|
|
|
;; (setf (ep-qx *ep*) (floor x 8)) |
|
;; (setf (ep-qy *ep*) (floor y 8)) |
|
(setf (ep-qcoord *ep*) |
|
(list (floor x 8) |
|
(floor x 8))) |
|
|
|
;; (setf (ep-ex *ep*) (floor (- x (* (ep-qx *ep*) 8)))) |
|
;; (setf (ep-ey *ep*) (floor (- y (* (ep-qy *ep*) 8)))) |
|
(setf (ep-spos *ep*) |
|
(list (floor (- x (* (ep-qx *ep*) 8))) |
|
(floor (- y (* (ep-qy *ep*) 8))))) |
|
|
|
(let ((qx (ep-qx *ep*)) (qy (ep-qy *ep*)) |
|
(ex (ep-ex *ep*)) (ey (ep-ey *ep*))) |
|
(when (< qx 0) (setq flag t qx 0 ex 0)) |
|
(when (< 7 qx) (setq flag t qx 7 ex 7)) |
|
(when (< qy 0) (setq flag t qy 0 ey 0)) |
|
(when (< 7 qy) (setq flag t qy 7 ey 7)) |
|
(setf (ep-qcoord *ep*) (list qx qy)) |
|
(setf (ep-spos *ep*) (list ex ey))) |
|
|
|
|
|
(assert (valid-coord-p (ep-qcoord *ep*))) ; nf |
|
|
|
(cond (flag |
|
(msg "LT. UHURA: MESSAGE FROM STARFLEET COMMAND --~%") |
|
(msg " 'PERMISSION TO ATTEMPT CROSSING OF GALACTIC PERIMETER~%") |
|
(msg " IS HEREBY *DENIED*. SHUT DOWN YOUR ENGINES.'~%") |
|
(msg "CHIEF ENGINEER SCOTT: 'WARP ENGINES SHUT DOWN~%") |
|
(msg " AT SECTOR ~a OF QUADRANT ~a.'~%" |
|
(ep-spos *ep*) (ep-qcoord *ep*)) |
|
|
|
(set-smap 'E (ep-spos *ep*)) |
|
|
|
(when (mission-timeout-p) |
|
(fail-mission '+RC_TIMEOUT_AT_QUAD_EXIT+))) |
|
(t |
|
(cond ((and (eql (ep-qx *ep*) old-qx) (eql (ep-qy *ep*) old-qy)) |
|
(warp-time w1)) |
|
(t |
|
(proceed-time) |
|
(dec-energy n) |
|
t))) |
|
))) |
|
|
|
;; I don't see the validity of this function (sigh...) |
|
(defun compute-warp-destination (n1 spos0 vec qcoord0 &aux flag) |
|
(flet ((qv/ev (qv0 ev0 d) |
|
(floor (floor (+ ev0 (* 8 qv0) (* n1 d))) |
|
8))) |
|
(destructuring-bind (qx0 qy0) qcoord0 |
|
(destructuring-bind (ex0 ey0) spos0 |
|
(destructuring-bind (dx dy) vec |
|
(multiple-value-bind (qx ex) (qv/ev qx0 ex0 dx) |
|
(multiple-value-bind (qy ey) (qv/ev qy0 ey0 dy) |
|
;; when ran over quadrants, roll back to a boundary |
|
(when (< qx 0) (setq flag t)(setq qx 0)(setq ex 0)) |
|
(when (> qx 7) (setq flag t)(setq qx 7)(setq ex 7)) |
|
(when (< qy 0) (setq flag t)(setq qy 0)(setq ey 0)) |
|
(when (> qy 7) (setq flag t)(setq qy 7)(setq ey 7)) |
|
(values flag (list qx qy) (list ex ey))))))))) |
|
|
|
(defun exit-quad (n spos0 vec w1 &aux (flag nil)) |
|
(with-accessors+ (ep-spos ep-qcoord) *ep* |
|
(let ((qcoord0 (copy-seq ep-qcoord))) |
|
(multiple-value-setq (flag ep-qcoord ep-spos) |
|
(compute-warp-destination n spos0 vec qcoord0)) |
|
(cond (flag |
|
(msg "LT. UHURA: MESSAGE FROM STARFLEET COMMAND --~%") |
|
(msg " 'PERMISSION TO ATTEMPT CROSSING OF GALACTIC PERIMETER~%") |
|
(msg " IS HEREBY *DENIED*. SHUT DOWN YOUR ENGINES.'~%") |
|
(msg "CHIEF ENGINEER SCOTT: 'WARP ENGINES SHUT DOWN~%") |
|
(msg " AT SECTOR ~a OF QUADRANT ~a.'~%" ep-spos ep-qcoord) |
|
|
|
;; need to re-plot 'E, since we will return nil below |
|
(set-smap 'E ep-spos) |
|
|
|
;; FIXME |
|
;; the timeout test here seems to be almost meaningless |
|
;; (maybe something like PROCEED-TIME is missing?) |
|
(when (mission-timeout-p) |
|
(fail-mission '+RC_TIMEOUT_AT_QUAD_EXIT+)) |
|
|
|
nil) |
|
|
|
((coord= ep-qcoord qcoord0) |
|
(warp-time w1) ; proceed-time (maybe w/ some modification for W1), |
|
; accompanying mission-timeout check. |
|
; -- re-enter the same quadrant after return here |
|
t) |
|
|
|
(t |
|
(proceed-time) |
|
(dec-energy n) |
|
t) ; -- enter a new quadrant after return here |
|
)) |
|
)) |
|
|
|
(defun nav4 (c1 n w1) |
|
(with-accessors+ (ep-spos) *ep* |
|
(let* ((spos0 (copy-seq ep-spos)) |
|
(spos (copy-seq spos0)) |
|
(vec (multiple-value-list (course-to-vec c1)))) |
|
(set-smap nil ep-spos) |
|
(dotimes (.ign. n) |
|
(map-into spos #'+ spos vec) |
|
(setf ep-spos (mapcar #'round-to-nearest-int spos)) |
|
(unless (valid-spos-p ep-spos) |
|
(return-from nav4 |
|
(if (exit-quad n spos0 vec w1) |
|
(progn (enter-quadrant) t) |
|
nil))) |
|
(msg "~a" ep-spos) |
|
(unless (null (get-smap ep-spos)) |
|
;; step back one unit of vec |
|
(map-into ep-spos (lambda (v d) (floor (- v d))) ep-spos vec) |
|
(assert (valid-spos-p ep-spos)) |
|
(msg "~%WARP ENGINES SHUT DOWN AT ") |
|
(msg "SECTOR ~a DUE TO BAD NAVAGATION" ep-spos) |
|
(return))) |
|
(set-smap 'E ep-spos) |
|
(dec-energy n) |
|
(msg "~%") |
|
(short-range-sensor) |
|
t))) |
|
|
|
#+:hoge |
|
(defun old-nav4 (c1 n w1) |
|
(let ((x (ep-ex *ep*)) (y (ep-ey *ep*)) |
|
(x0 (ep-ex *ep*)) (y0 (ep-ey *ep*)) |
|
(old-qx (ep-qx *ep*)) (old-qy (ep-qy *ep*)) |
|
dx dy) |
|
|
|
;; (multiple-value-setq (dx dy) (old-course-to-vec c1)) |
|
(multiple-value-setq (dx dy) (course-to-vec c1)) |
|
|
|
(set-smap nil (ep-spos *ep*)) |
|
|
|
(dotimes (i n) |
|
(incf x dx)(incf y dy) |
|
;; (setf (ep-ex *ep*) (round-to-nearest-int x)) |
|
;; (setf (ep-ey *ep*) (round-to-nearest-int y)) |
|
(setf (ep-spos *ep*) |
|
(list (round-to-nearest-int x) (round-to-nearest-int y))) |
|
|
|
(cond ((not (and (<= 0 (ep-ex *ep*) 7) |
|
(<= 0 (ep-ey *ep*) 7))) |
|
(return-from nav4 |
|
(cond ((exit-quad n x0 y0 dx dy w1 old-qx old-qy) |
|
(enter-quadrant) t) |
|
(t nil)))) |
|
(t (msg "~a" (ep-spos *ep*)))) |
|
|
|
;; FIXME |
|
(when (aref (smap *sec*) (ep-ex *ep*) (ep-ey *ep*)) |
|
;; (setf (ep-ex *ep*) (floor (- x dx))) |
|
;; (setf (ep-ey *ep*) (floor (- y dy))) |
|
(setf (ep-spos *ep*) |
|
(list (floor (- x dx)) (floor (- y dy)))) |
|
|
|
(msg "~%WARP ENGINES SHUT DOWN AT ") |
|
(msg "SECTOR ~a DUE TO BAD NAVAGATION" (ep-spos *ep*)) |
|
(return))) |
|
|
|
(set-smap 'E (ep-spos *ep*)) |
|
|
|
(dec-energy n) |
|
(msg "~%") |
|
(short-range-sensor) |
|
t)) |
|
|
|
;;; and finally nav |
|
|
|
(defun nav () |
|
(and-let* ((c1 (input-course "LT. SULU")) |
|
(w1 (input-nav-factor)) |
|
(n (determine-nav-energy w1))) |
|
(klingon-attack-at-warp) |
|
(repair-for-warp w1) |
|
(damage-by-warp) |
|
(when (nav4 c1 n w1) |
|
(warp-time w1)))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; long-range-sensor (command 2) |
|
|
|
(defun print-lrs-map (q1 &optional force) ; in fact, force is for debug |
|
(with-accessors+ (quad-n-klingon quad-n-base quad-n-star) q1 |
|
(if (or force (quad-scanned-p q1)) |
|
(msg " ~1a~1a~1a" quad-n-klingon quad-n-base quad-n-star) |
|
(msg " ***")))) |
|
|
|
(defun long-range-sensor () |
|
(cond ((minusp (damage-of +DEV_LRS+)) |
|
(msg "LONG RANGE SENSORS ARE INOPERABLE.~%")) |
|
(t |
|
(msg "LONG RANGE SCAN FOR QUADRANT ~a~%" (ep-qcoord *ep*)) |
|
(destructuring-bind (x y) (ep-qcoord *ep*) |
|
(loop for i from -1 to 1 do |
|
(loop for j from -1 to 1 do |
|
(aif (quadrant-at-xy (+ x i) (+ y j)) |
|
(progn (setf (quad-scanned-p it) t) |
|
(print-lrs-map it)) |
|
(msg " ***"))) |
|
(msg "~%")))))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; phaser (command 3) |
|
|
|
(defun phaser4 (x) |
|
(decf (ep-energy *ep*) x) |
|
(let* ((x1 (if (minusp (damage-of +DEV_COMPUTER+)) (random x) x)) |
|
(h1 (floor (/ x1 (n-klingon))))) |
|
(setq *klingon-turn-p* t) |
|
(loop-for-klingons (k) |
|
(with-accessors+ (kli-spos kli-energy) k |
|
(let ((h (floor (* (/ h1 (distance-to-klingon k)) |
|
(+ 2 (/ (random 10) 10)))))) |
|
(cond ((<= h (* (kli-energy k) 0.15)) |
|
(msg "SENSORS SHOW NO DAMAGE TO ENEMY AT ~a.~%" kli-spos)) |
|
(t |
|
(decf (kli-energy k) h) |
|
(msg "~a UNIT HIT ON KLINGON AT SECTOR ~a.~%" h kli-spos) |
|
(unless (plusp kli-energy) |
|
(delete-klingon k) |
|
(msg " (SENSORS SHOW ~3,2f UNITS REMAINING)~%" kli-energy))))))))) |
|
|
|
;; FORMER phaser3 |
|
(defun input-phaser-energy () |
|
(with-accessors+ (ep-energy) *ep* |
|
(loop |
|
(msg "PHASERS LOCKED ON TARGET; ") |
|
(msg "ENERGY AVAILABLE = ~a UNITS~%" ep-energy) |
|
(msg "NUMBER OF UNITS TO FIRE ? ") |
|
(let ((x (read-input nil))) |
|
(cond ((not (numberp x)) (return-from input-phaser-energy nil)) |
|
((<= x 0) (return-from input-phaser-energy nil)) |
|
((<= 0 (- ep-energy x)) (return-from input-phaser-energy x))))))) |
|
|
|
(defun no-enemy () ; shared with comp-torpedo |
|
(msg "SCIENCE OFFICER SPOCK: 'SENSORS SHOW NO ENEMY SHIPS~%") |
|
(msg " IN THIS QUADRANT'")) |
|
|
|
(defun phaser () |
|
(cond ((minusp (damage-of +DEV_PHASER+)) |
|
(msg "PHASERS INOPERATIVE.~%")) |
|
((not (plusp (n-klingon))) |
|
(no-enemy)) |
|
(t |
|
(if (minusp (damage-of +DEV_COMPUTER+)) |
|
(msg "COMPUTER FAILURE HAMPERS ACCURACY.~%") |
|
(msg "PHASERS LOCKED ON TARGET; ")) |
|
(awhen (input-phaser-energy) |
|
(phaser4 it) |
|
|
|
;; added to the PREV-VER (CHANGED) |
|
(unless (plusp *klingon-total*) |
|
(end-of-mission-silently '+RC_KLINGON_DESTROYED_WITH_PHASER+)) |
|
)))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; torpedo (command 4) |
|
|
|
(defun delete-star (spos) |
|
(set-smap nil spos) |
|
(decf (quad-n-star (ep-current-quadrant)))) |
|
|
|
(defun delete-base (spos) |
|
(set-smap nil spos) |
|
(decf (n-base)) |
|
(decf *base-total*) |
|
(decf (quad-n-base (ep-current-quadrant)))) |
|
|
|
;; really I'm not sure why the following (plusp *base-total*) matters |
|
(defun destroy-base () |
|
;; DELETE-BASE is called just before DESTROY-BASE, and |
|
;; *base-total* has just been decremented. (inlining to TORPEDO-FIRE ?) |
|
(cond ((or (plusp *base-total*) |
|
;; the following expr in the PREV-VER, |
|
;; (< (- *time* *time-0* *t-period*) *klingon-total*), i.e. |
|
;; (< (- *time* (+ *time-0* *t-period*)) *klingon-total*) |
|
;; seems to be a bug, and probably the correct expr is below: |
|
;; (>= (- (+ *time-0* *t-period*) *time*) *klingon-total*), and |
|
;; (- (+ *time-0* *t-period*) *time*) is equal to (rest-period). |
|
;; (FIXED) |
|
(<= *klingon-total* (rest-period)) |
|
) |
|
(msg "STARFLEET COMMAND REVIEWING YOUR RECORD TO CONSIDER") |
|
(msg "COURT MARTIAL!") |
|
(setf (ep-docked-p *ep*) nil) |
|
(setq *klingon-turn-p* t)) |
|
(t |
|
(msg "THAT DOES IT, CAPTAIN!! YOU ARE HEREBY RELIEVED OF COMMAND") |
|
(msg "AND SENTENCED TO 99 STARDATES AT HARD LABOR ON CYGNUS 12!!") |
|
(fail-mission '+RC_ACCIDENTAL_TORPEDO_FIRE+)))) |
|
|
|
(defun torpedo-fire (c1) |
|
(let ((torpedo-pos (copy-seq (ep-spos *ep*))) |
|
(vec (multiple-value-list (course-to-vec c1)))) |
|
(msg "TORPEDO TRACK:") |
|
(loop |
|
;; The Bresenham's algorithm, i.e. integer-only method, can be used here, |
|
;; but we have not for apparent simplicity (right?) |
|
(map-into torpedo-pos #'+ torpedo-pos vec) |
|
(let ((spos (mapcar #'round-to-nearest-int torpedo-pos))) |
|
(unless (valid-spos-p spos) |
|
(msg "~%TORPEDO MISSED.~%") |
|
(return)) |
|
(case (get-smap spos) |
|
(K (msg "~%") |
|
(delete-klingon-at spos) |
|
(unless (plusp *klingon-total*) |
|
(end-of-mission-silently '+RC_KLINGON_DESTROYED_WITH_TORPEDO+)) |
|
(return)) |
|
(S (msg "~%STAR AT ~a ABSORBED TORPEDO ENERGY.~%" spos) |
|
(delete-star spos) |
|
(return)) |
|
(B (msg "~%*** STARBASE DESTROYED ***~%") |
|
(delete-base spos) |
|
(destroy-base) |
|
(return))) |
|
(msg "~a" spos))))) |
|
|
|
(defun torpedo () |
|
(with-accessors+ (ep-energy ep-torpedo) *ep* |
|
(cond ((not (plusp ep-torpedo)) |
|
(msg "ALL PHOTON TORPEDOES EXPENDED.~%")) |
|
((minusp (damage-of +DEV_TORPEDO+)) |
|
(msg "PHOTON TUBES ARE NOT OPERATIONAL.~%")) |
|
(t |
|
(msg "PHOTON TORPEDO ") |
|
(awhen (input-course "ENSIGN CHEKOV") |
|
(decf ep-torpedo 1) |
|
(decf ep-energy 2) |
|
(torpedo-fire it) |
|
(setq *klingon-turn-p* t)))))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; shield (command 5) |
|
|
|
(defun shield () |
|
(when (minusp (damage-of +DEV_DAMAGE_REPORT+)) |
|
(msg "SHIELD CONTROL INOPERABLE.~%") |
|
(return-from shield)) |
|
(with-accessors+ (ep-energy ep-shield ep-total-energy) *ep* |
|
(msg "ENERGY AVAILABLE =~a. NUMBER OF UNITS TO SHIELDS ? " ep-total-energy) |
|
(let ((x (read-input nil))) |
|
(cond ((or (minusp x) (= x ep-shield)) |
|
(msg "<SHIELDS UNCHANGED>~%")) |
|
((< ep-total-energy x) |
|
(msg "SHIELD CONTROL: 'THIS IS NOT THE FEDERATION TREASURY.'" ) |
|
(msg "<SHIELDS UNCHANGED>")) |
|
(t |
|
(incf ep-energy (- ep-shield x)) |
|
(setf ep-shield x) |
|
(msg "DEFLECTOR CONTROL ROOM:") |
|
(msg " 'SHIELDS NOW AT ~a UNITS PER YOUR COMMAND.'" x)))))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; damage report (command 6) |
|
|
|
(defun repair-all () |
|
(loop for dmg across (ep-damage-arr *ep*) |
|
for i from 0 |
|
when (progn |
|
;; if this assertion always holds, the when clause |
|
;; is not necessary (and it's likely to be). |
|
(assert (not (plusp dmg))) |
|
(minusp dmg)) |
|
do (setf (damage-of i) 0))) |
|
|
|
(defun show-stat-repair () |
|
(msg "DEVICE STATE OF REPAIR~%") |
|
(msg "------ ---------------~%") |
|
(loop for dmg across (ep-damage-arr *ep*) |
|
for i from 0 |
|
for name = (device-name i) |
|
;; in the PREV-VER, (* 0.1 (floor (* 100 dmg))) is displayed. |
|
;; first 0.1 is probably clerical error of 0.01. |
|
;; second such rigid round-off is not necessary for ~3,2f, |
|
;; and it's just enough to use ~3,2f. (CHANGED) |
|
do (msg "~a ~3,2f~%" name dmg) )) |
|
|
|
(defun damage-report() |
|
;; in the PREV-VER, damage-array index had been +DEV_SHIELD+ (FIXED) |
|
(if (minusp (damage-of +DEV_DAMAGE_REPORT+)) |
|
(msg "DAMAGE CONTROL REPORT NOT AVAILABLE.~%") |
|
(show-stat-repair)) |
|
;; FORMER docked-repair |
|
(when (ep-docked-p *ep*) |
|
(let ((cnt (count-if #'minusp (ep-damage-arr *ep*)))) |
|
(unless (zerop cnt) |
|
;; FORMER need-repair |
|
(let* ((magic (ep-damage-repair-magic-number *ep*)) |
|
(d3 (+ (* 0.1 cnt) magic))) |
|
(when (<= 1 d3) (setq d3 0.9)) |
|
(msg "TECHNICIANS STANDING BY TO EFFECT REPAIRS TO YOUR SHIP;") |
|
;; the PREV-VER had done a rigid round-off (CHANGED to use just ~3,2f) |
|
(msg "ESTIMATED TIME TO REPAIR: ~3,2f STARDATES." d3) |
|
(when (y-or-n-p "WILL YOU AUTHORIZE THE REPAIR ORDER") |
|
(repair-all) |
|
(proceed-time (+ d3 0.1)) |
|
(show-stat-repair))))))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; computer (command 7) |
|
|
|
(defun comp-stat-repo () |
|
(msg " STATUS REPORT:~% -------------~%") |
|
(msg " ~a~:* KLINGON~:@(~p~) LEFT.~%" *klingon-total*) |
|
(msg " MISSION MUST BE COMPLETED IN ~5,2f STARDATES.~%" |
|
;; the following exp seems to be a bug in the PREV-VER, |
|
;; since (* (/ (floor x) 10) 10) always returns (floor x), |
|
;; and I guess it had probably meant to be (/ (floor (* 10 x)) 10) |
|
;; which then means round-off-at-2nd-dp, i.e. |
|
;; (* (/ (floor (+ *time-0* *t-period* (- *time*))) 10) 10) is really |
|
;; (/ (floor (* 10 (+ *time-0* *t-period* (- *time*)))) 10) |
|
;; -> (/ (floor (* 10 (- (+ *time-0* *t-period*) *time*))) 10) |
|
;; -> (/ (floor (* 10 (rest-period)) 10) |
|
;; -> (round-off-at 2nd-dp (rest-period)) |
|
;; finally round-off is not necessary, since we just use ~5,2f (CHANGED) |
|
#+:hoge |
|
(* (/ (floor (+ *time-0* *t-period* (- *time*))) 10) 10) |
|
(rest-period) |
|
) |
|
(cond ((plusp *base-total*) |
|
(msg " THE FEDERATION IS MAINTAINING ~a~:* STARBASE~:@(~p~) ~ |
|
IN THE GALAXY.~2%" *base-total*)) |
|
(t |
|
(msg "YOUR STUPIDITY HAS LEFT YOU ON YOUR OWN IN~%") |
|
(msg " THE GALAXY -- YOU HAVE NO STARBASES LEFT!~2%"))) |
|
(damage-report)) |
|
|
|
(defun comp-torpedo () ; compute torpedo cource |
|
(cond ((not (plusp (n-klingon))) |
|
(no-enemy)) |
|
(t |
|
(msg "FROM ENTERPRISE TO KLINGON BATTLE CRUSER~:@(~p~)~%" |
|
(n-klingon)) |
|
(loop-for-klingons (k) |
|
(with-accessors+ (kli-spos) k |
|
(msg "KLINGON at ~a: DIRECTION = ~3,2f~%" |
|
kli-spos |
|
(p2p-course (ep-spos *ep*) kli-spos) )))))) |
|
|
|
(defun disp-dir-and-dist (spos0 spos1) |
|
(multiple-value-bind (distance course) (p2p-distance/course spos0 spos1) |
|
(msg "DIRECTION = ~3,2f~%" course) |
|
(msg "DISTANCE = ~5,3f~%" distance))) |
|
|
|
(defun base-nav () ; starbase nav data |
|
(if (zerop (n-base)) |
|
(msg "MR. SPOCK: 'SENSORS SHOW NO STARBASES IN THIS QUADRANT.'~%") |
|
(disp-dir-and-dist (ep-spos *ep*) (base-spos)))) |
|
|
|
(defun comp-calc () ; calculator |
|
(prog (spos0 spos1) |
|
(msg "DIRECTION/DISTANCE CALCULATOR:~%") |
|
(msg "YOU ARE AT QUADRANT ~a, SECTOR ~a.~%" (ep-qcoord *ep*) (ep-spos *ep*)) |
|
(setq spos0 (read-spos "PLEASE ENTER INITIAL COORDINATES (X Y)? ")) |
|
(setq spos1 (read-spos "FINAL COORDINATES (X Y)? ")) |
|
(disp-dir-and-dist spos0 spos1))) |
|
|
|
(defun comp-galaxy-rec () |
|
(msg " ~49:@< COMPUTER RECORD OF GALAXY FOR QUADRANT ~a~>~%" |
|
(ep-qcoord *ep*)) |
|
(msg " 0 1 2 3 4 5 6 7~%") |
|
(msg " +-----+-----+-----+-----+-----+-----+-----+-----+") |
|
(dotimes (i 8) |
|
(msg "~% ~a |" i) |
|
(dotimes (j 8) |
|
(print-lrs-map (quadrant-at-xy i j t)) |
|
(msg " ")))) |
|
|
|
(defun comp-galaxy-name-map () |
|
(flet ((qn (i j) (quad-name i j nil))) |
|
(msg " ~49:@<THE GALAXY~>~%") |
|
(msg " 0 1 2 3 4 5 6 7~%") |
|
(msg " +-----+-----+-----+-----+-----+-----+-----+-----+") |
|
(loop for i from 0 below 8 do |
|
(msg "~% ~a |~23:@<~a~> ~23:@<~a~>" i (qn i 0) (qn i 4))))) |
|
|
|
(defun comp-help () |
|
(msg "FUNCTIONS AVAILABLE FROM LIBRARY-COMPUTER:~%") |
|
(msg "-----------------------------------------~%") |
|
(msg " G = CUMULATIVE GALTIC RECORD~%") ; 歴訪銀河記録 |
|
(msg " S = STATUS REPORT~%") ; 状況レポート |
|
(msg " T = PHOTON TORPEDO DATA~%") ; 光子魚雷データ |
|
(msg " B = STARBASE NAV DATA~%") ; 基地への航法データ |
|
(msg " N = DIRECTION/DISTANCE CALCULATOR~%") ; 航法計算/方向/距離 |
|
(msg " Z = GALAXY 'REGION NAME' MAP~%")) ; 銀河の領域名一覧 |
|
|
|
(defun computer () |
|
(when (minusp (damage-of +DEV_COMPUTER+)) |
|
(msg "COMPUTER DISABLED.~%") |
|
(return-from computer)) |
|
(case (read-input "COMPUTER ACTIVE AND AWAITING COMMAND ") |
|
(G (comp-galaxy-rec)) |
|
(S (comp-stat-repo)) |
|
((T) (comp-torpedo)) |
|
(B (base-nav)) |
|
(N (comp-calc)) |
|
(Z (comp-galaxy-name-map)) |
|
(otherwise (comp-help)))) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; help-command (command x) |
|
|
|
(defun help-command () |
|
(msg "ENTER ONE OF THE FOLLOWING:~%") |
|
(msg "--------------------------~%") |
|
(msg " W (WARP)~%") ; ワープ (WF=1で1quad分航行) |
|
(msg " S (FOR SHORT RANGE SENSOR SCAN)~%") ; ショートレンジセンサ |
|
(msg " L (FOR LONG RANGE SENSOR SCAN)~%") ; ロングレンジセンサ |
|
(msg " P (TO FIRE PHASERS)~%") ; フェーザー砲 |
|
(msg " T (TO FIRE PHOTON TORPEDOES)~%") ; 光子魚雷 |
|
(msg " Z (TO RAISE OR LOWER SHIELDS)~%") ; シールドスクリーン制御 |
|
(msg " R (FOR DAMAGE CONTROL REPORTS)~%") ; 障害レポート |
|
(msg " C (TO CALL ON LIBRARY-COMPUTER)~%") ; ライブラリコンピュータ呼出し |
|
(msg " XXX (TO RESIGN YOUR COMMAND)~%") ; 作戦の新規やり直し |
|
(msg " zzz (break for debug)~%")) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; mission-loop (aka command loop) |
|
|
|
(defun check-enough-energy () |
|
(with-accessors+ (ep-energy ep-shield) *ep* |
|
(unless (and (< 10 (+ ep-shield ep-energy)) |
|
(or (< 10 ep-energy) |
|
(zerop (damage-of +DEV_DAMAGE_REPORT+)))) |
|
(msg "** FATAL ERROR **~%") |
|
(msg "YOU'VE JUST STRANDED YOUR SHIP IN SPACE.~%") |
|
(msg "YOU HAVE INSUFFICIENT MANEUVERING ENERGY,~%") |
|
(msg "AND SHIELD CONTROL IS PRESENTLY INCAPABLE OF~%") |
|
(msg "CROSS-CIRCUITING TO ENGINE ROOM!!~%") |
|
(fail-mission '+RC_ENERGY_EXHAUSED+)))) |
|
|
|
(defun mission-loop () |
|
(loop |
|
(assert (plusp *klingon-total*)) |
|
|
|
(when (mission-timeout-p) |
|
(fail-mission '+RC_MISSION_TIMEOUT+)) |
|
|
|
(when *klingon-turn-p* |
|
(klingon-attack) ; klingons' turn after phaser/torpedo |
|
(setq *klingon-turn-p* nil)) |
|
|
|
(check-enough-energy) |
|
|
|
(case (read-input "~%COMMAND? ") |
|
(W (nav)) |
|
(S (short-range-sensor)) |
|
(L (long-range-sensor)) |
|
(P (phaser)) |
|
((T) (torpedo)) |
|
(Z (shield)) |
|
(R (damage-report)) |
|
(C (computer)) |
|
(XXX (end-of-mission '+RC_COMMAND_EXIT+)) |
|
(zzz (break "We are at mission-loop:~%~s" *ep*)) |
|
(otherwise (help-command))))) |
|
|
|
;;;=================================================================== |
|
;;; main logic |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; overall initializer |
|
|
|
;; Maybe increment *base-total* and/or *klingon-total*, |
|
;; also may change ep-qcoord of *ep* |
|
(defun adjust-total-klingons/bases () |
|
(when (zerop *base-total*) |
|
;; tweak current quadrant, i.e. ep-qcoord of *ep* |
|
(let ((q1 (quadrant-at (ep-qcoord *ep*) t))) |
|
(incf (quad-n-base q1)) |
|
(incf *base-total*) |
|
(when (< (quad-n-klingon q1) 2) |
|
(incf (quad-n-klingon q1)) |
|
(incf *klingon-total*))) |
|
;; current quadrant might be changed |
|
(setf (ep-qcoord *ep*) (list (rand8) (rand8))))) |
|
|
|
;; Set 11 global variables among 12 to initial states. |
|
;; The rest one, *sec*, is initialized later at initialize-sector. |
|
;; (FYI, the PREV-VER has 23 global vars) |
|
(defun initialize-trek () |
|
|
|
(initialize-klingons) ; set *klingons* |
|
(initialize-enterprise) ; set *ep* |
|
(initialize-quadrants) ; set *quadrants*, and |
|
; *star-total*, *base-total*, *klingon-total* |
|
|
|
(adjust-total-klingons/bases) ; may modify some vars (see above adjust-...) |
|
(assert (plusp *base-total*)) ; at least one base per quadrant |
|
|
|
;; *time*, *t-period* |
|
(setq *time* (* (+ (random 20) 20) 100) |
|
*t-period* (+ (random 10) 25)) |
|
(when (< *t-period* *klingon-total*) |
|
(setq *t-period* (1+ *klingon-total*))) |
|
|
|
;; and *time-0*, *klingon-total-0*, *klingon-turn-p* |
|
(setq *time-0* *time* |
|
*klingon-total-0* *klingon-total* |
|
*klingon-turn-p* nil) |
|
) |
|
|
|
;;;------------------------------------------------------------------- |
|
;;; top-level |
|
|
|
(defun display-title () |
|
(when *resume-trek-p* (return-from display-title)) |
|
(msg "THE USS ENTERPRISE --- NCC-1701~%") |
|
(msg " ,------*------,~%" ) |
|
(msg " ,------------- '--- ------'~%" ) |
|
(msg " '-------- --' / /~%" ) |
|
(msg " ,---' '-------/ /--,~%" ) |
|
(msg " '----------------'~%" )) |
|
|
|
(defun display-mission () |
|
(msg "YOUR ORDERS ARE AS FOLLOWS:~%") |
|
(msg "--------------------------~%") |
|
(msg " DESTROY THE ~a KLINGON WARSHIPS WHICH HAVE INVADED~%" *klingon-total*) |
|
(msg " THE GALAXY BEFORE THEY CAN ATTACK FEDERATION HEADQUARTERS~%") |
|
(msg " ON STARDATE ~5,2f. ~ |
|
THIS GIVES YOU ~a DAYS.~%" (end-time) (given-period)) |
|
(msg " THERE ~:[IS~;ARE~] ~a~:* STARBASE~:@(~p~) IN THE GALAXY FOR ~ |
|
RESUPPLYING YOUR SHIP.~2%" (/= *base-total* 1) *base-total*)) |
|
|
|
(defun celebrate-success () |
|
(msg "CONGRATULATIONS, CAPTAIN! THE LAST KLINGON BATTLE CRUISER~%") |
|
(msg "MENACING THE FEDERATION HAS BEEN DESTROYED.~2%") |
|
(msg "YOUR EFFICIENCY RATING IS ~s" (efficiency-rating))) |
|
|
|
(defun more-mission-p () |
|
(when (zerop *base-total*) |
|
(return-from more-mission-p nil)) |
|
(msg "~%THE FEDERATION IS IN NEED OF A NEW STARSHIP COMMANDER~%") |
|
(msg "FOR A SIMILAR MISSION -- IF THERE IS A VOLUNTEER,~%") |
|
(msg "LET HIM STEP FORWARD AND ENTER 'AYE' " ) |
|
(eql 'AYE (read-input nil))) |
|
|
|
(defun carry-out-mission () ; returns whether success or not |
|
(enter-quadrant) |
|
(ecase (catch 'game-end (mission-loop)) |
|
((+RC_NOTHROW+) |
|
(error "+RC_NOTHROW+: currently not used")) |
|
((+RC_KLINGON_DESTROYED_WITH_PHASER+ |
|
+RC_KLINGON_DESTROYED_WITH_TORPEDO+) |
|
t) ; success |
|
((+RC_COMMAND_EXIT+) |
|
nil) ; not success, though not failure |
|
((+RC_TIMEOUT_BY_WARP+ |
|
+RC_TIMEOUT_AT_QUAD_EXIT+ |
|
+RC_ENTERPRISE_DESTROYED+ |
|
+RC_ACCIDENTAL_TORPEDO_FIRE+ |
|
+RC_MISSION_TIMEOUT+ |
|
+RC_ENERGY_EXHAUSED+) |
|
nil) ; failure |
|
)) |
|
|
|
(defun trek (&optional *resume-trek-p*) |
|
(display-title) |
|
(loop |
|
(when (or *resume-trek-p* |
|
(progn |
|
(initialize-trek) |
|
(display-mission) |
|
(yes-or-no-p "ARE YOU READY TO ACCEPT COMMAND?"))) |
|
(when (carry-out-mission) |
|
(celebrate-success))) |
|
(unless (more-mission-p) |
|
(return))) |
|
(msg "~%*** END ***~%")) |
|
|
|
;;; eof |
