Skip to content

Instantly share code, notes, and snippets.

@nfunato

nfunato/1. README.org

Last active January 10, 2022 06:42
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save nfunato/7dbdb8f6f2c93f33d6e8b8f940e18da9 to your computer and use it in GitHub Desktop.
Save nfunato/7dbdb8f6f2c93f33d6e8b8f940e18da9 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
1. README.org

Revision History

このgist entryには、 ここ(zenn) にある記事の参照用コードが含まれています。

内容

gist entryのrevisionの概要

  • revision5以降

    改変があれば　追加/修正が加えられます

  • revision4:

    README と trek-refactor-latest.lisp 追加

  • revision3:

    revision2に trek-refactor-annotated.lisp を追加

  • revision2

    revision1のtrek.lspをSBCL上でロードできるようにしたものを収録(revision1からの差分がtrek.lspへのパッチになる)

  • revision1

    作者に御了承いただき http://www.takeoka.org/~take/trek/trek-manj.html にあるtrek.lspを収録

Raw
2. trek-refactor-latest.lisp
;;;; 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 (take@axe-inc.co.jp)
;;;; 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 (nfunato@acm.org)
;;;; 2021/DEC/13
;;;===================================================================
;;; 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
;;;
(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)))))
(defun COURSE-TO-VEC (course &optional distance)
(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)
(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)))))
;;;-------------------------------------------------------------------
;;; 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
;; the followings 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
spos ; position in sector, aka spos
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
)
;; 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+
(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 ()
(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)
nil)
(t
(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."))
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 / damage-by-warp / dec-energy / warp-time
(defun repair-for-warp (w1)
(declare (ignore w1))
(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)))))))
(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))))
(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+)))
;; nav4
(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)))
;;; 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)))))))))
(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)
(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))))
(defun destroy-base ()
;; DELETE-BASE is called just before DESTROY-BASE, and
;; *base-total* has just been decremented
(cond ((or (plusp *base-total*)
(<= *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)
do (msg "~a ~3,2f~%" name dmg) ))
(defun damage-report()
(if (minusp (damage-of +DEV_DAMAGE_REPORT+))
(msg "DAMAGE CONTROL REPORT NOT AVAILABLE.~%")
(show-stat-repair))
(when (ep-docked-p *ep*)
(let ((cnt (count-if #'minusp (ep-damage-arr *ep*))))
(unless (zerop cnt)
(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;")
(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.~%" (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.
(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
Raw
3. trek-refactor-annotated.lisp
;;;; 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 (take@axe-inc.co.jp)
;;;; 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 (nfunato@acm.org)
;;;; 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
Raw
4. trek.lsp
#|
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 (take@axe-inc.co.jp)
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
tested system:
GCL2.2.6 under WindowsXP
GCL2.2.5 undef FreeBSD5.4R
ALLEGRO-V8.0 under WindowsXP
Clisp under MacOS 10.3.9 (PPC)
|#
;(si:chdir "/take/src/trek")
;(load "trek.lsp")
;(trek)
;#+:GCL (si::use-fast-links nil)
;;;
(defstruct klingon
(x 0)
(y 0)
(energy 0))
(defstruct quad
(base 0)
(star 0)
(klingon 0)
(visit nil))
;;; direction vector. 9th data is same as 1st data
(defvar *cx*
(make-array '9 :initial-contents
'(-1 -1 0 1 1 1 0 -1 -1)))
(defvar *cy*
(make-array '9 :initial-contents
'(0 1 1 1 0 -1 -1 -1 0)))
;;;Constant
(defconstant +full-energy+ 3000)
(defconstant +full-torpedo+ 10) ; max of torpedoes
(defconstant +klingon-max-energy+ 200)
;;; Global var
(defvar *ggg* (make-array '(8 8) :initial-element 0))
(defvar *kkk* (make-array '(4) :initial-element 0))
(defvar *time* 0)
(defvar *time0* 0)
(defvar *t-period* 0)
(defvar *base-total* 0) ; Base total No.
(defvar *klingon-total* 0) ; Klingon total No.
(defvar *c-klingons* 0) ; current-Klingons
(defvar *c-bases* 0) ; current-Bases
(defvar *c-stars* 0) ; current-Stars
(defvar *bx* 0) ; Base-X pos in Quad
(defvar *by* 0) ; Base-Y pos in Quad
(defvar *ex* 0) ; Enterprise X pos in Quad
(defvar *ey* 0) ; Y pos in Quad
(defvar *qx* 0) ;Quadorant X
(defvar *qy* 0) ;Quadorant Y
(defvar *energy* 0)
(defvar *torpedo* 0) ;No. of torpedoes
(defvar *shield* 0) ;shield
(defvar *docked* nil) ; docked
;;; global flags
(defvar *klingon-attack* nil) ; turn of Klingon
(defvar *success* nil) ;success flag
(defvar *mission-end* nil) ;mission terminated
(defun title ()
(format t "THE USS ENTERPRISE --- NCC-1701~%")
(format t " ,------*------,~%" )
(format t " ,------------- '--- ------'~%" )
(format t " '-------- --' / /~%" )
(format t " ,---' '-------/ /--,~%" )
(format t " '----------------'~%" )
)
(defmacro aset (a n v)
`(setf (aref ,a ,n) ,v))
(defmacro aset2 (a x y v)
`(setf (aref ,a ,x ,y ) ,v))
(defvar *damage-repair-magic-number* nil)
(defvar *klingon-org* nil)
(defvar *ddd* nil)
(defun init()
(setq *damage-repair-magic-number* (/(random 50) 100)) ;D4=.5*RND(1)
; (setq *bbb* (make-array 2 :initial-element 0))
(setq *success* nil)
(setq *mission-end* nil)
(setq *klingon-attack* nil)
(setq *klingon-org* 0)
(dotimes (i 4)
(setf (aref *kkk* i) (make-klingon)))
(setq *time* (* (+ (random 20) 20) 100)) ; current time
(setq *time0* *time*) ; initial time
(setq *t-period* (+ (random 10) 25)) ; end time
(setq *docked* nil) ; docked
(setq *energy* +full-energy+)
(setq *torpedo* +full-torpedo+) ;No. of torpedoes
(setq *shield* 0) ;shield
)
(defun init2()
(setq *qx* (random 8)) ;Quadorant X
(setq *qy* (random 8)) ;Quadorant Y
(setq *ex* (random 8)) ;Sector X
(setq *ey* (random 8)) ;Sector Y
(setq *ddd* (make-array 10 :initial-element 0)) ;no Damage
)
;470 DEF FND(D)=SQR((K(I,1)-S1)^2+(K(I,2)-S2)^2)
(defun klingon-distance(i)
(let* (
(k (aref *kkk* i))
(xx1 (- (klingon-x k) *ex*))
(xx2 (- (klingon-y k) *ey*)))
(floor (+(sqrt (+(* xx1 xx1) (* xx2 xx2))) 0.5))))
;475 DEF FNR(R)=INT(RND(R)*7.98+1.01)
(defun rnd1-8()
(1+ (random 8)))
(defun fnrand()
(random 8))
(defun trek()
(title)
(loop
(trek1)
(if (not(more-mission)) (return)))
(format t "~%*** END ***~%"))
(defun trek1()
(init)
(init2)
(make-galaxy)
(print-mission)
(if (not(acceptp)) (return-from trek1))
;;;
(enter-quad)
(catch 'game-end
(mloop))
(when (or *success* (<= *klingon-total* 0))
(success)))
(defun make-galaxy1()
(let (k3 b3 r)
(setq *base-total* 0) ; Base total No.
(setq *klingon-total* 0) ; Klingon total No.
(dotimes (i 8)
(dotimes (j 8)
(incf *klingon-total*
(setq k3
(cond ((>(setq r (random 100)) 98) 3)
((> r 95) 2)
((> r 8) 1)
(t 0))))
(incf *base-total*
(setq b3
(cond ((>(random 100) 96) 1)
(t 0))))
(setf (aref *ggg* i j)
(make-quad
:klingon k3 :base b3 :star (rnd1-8)))))))
(defun make-galaxy()
(make-galaxy1)
(if(> *klingon-total* *t-period*) (setq *t-period* (1+ *klingon-total*)))
(cond ((zerop *base-total*)
(cond ((< (quad-klingon (aref *ggg* *qx* *qy*)) 2)
(incf *klingon-total*)
(incf (quad-klingon (aref *ggg* *qx* *qy*)))))
(setq *base-total* 1)
(incf (quad-base (aref *ggg* *qx* *qy*)))
(setq *qx* (fnrand))
(setq *qy* (fnrand))))
(setq *klingon-org* *klingon-total*))
(defun print-mission()
(format t "YOUR ORDERS ARE AS FOLLOWS:~%")
(format t "--------------------------~%")
(format t " DESTROY THE ~a KLINGON WARSHIPS WHICH HAVE INVADED~%"
*klingon-total*)
(format t " THE GALAXY BEFORE THEY CAN ATTACK FEDERATION HEADQUARTERS~%")
(format t " ON STARDATE ~5,2f. THIS GIVES YOU ~a DAYS.~%"
(+ *time0* *t-period*) *t-period* )
(format t
" THERE ~a ~a STARBASE~a IN THE GALAXY FOR RESUPPLYING YOUR SHIP.~%~%"
(if (eql *base-total* 1) "IS" "ARE")
*base-total*
(if (eql *base-total* 1) "" "S")))
#|
|#
(defun acceptp()
(format t "ARE YOU READY TO ACCEPT COMMAND? ('N' FOR End)")
(not(eql (read) 'n)))
(defun enter-quad ()
(let (#|k|#)
(setf (quad-visit (aref *ggg* *qx* *qy*)) t) ; make known Quad
(when(not(or (< *qx* 0) (> *qx* 7) (< *qy* 0) (> *qy* 7)))
(disp-quad-name (quad-name *qy* *qx* 0))
(enter-quad1)
;(format t "*c-bases*=~a *c-klingons*=~a *c-stars*=~a~%" *c-bases* *c-klingons* *c-stars*)
(repo-entering-quad-stat))
(init-sector)
(short-range-sensor)))
(defun disp-quad-name(qq)
(cond
((eql *time0* *time*)
(format t "YOUR MISSION BEGINS WITH YOUR STARSHIP LOCATED~%")
(format t "IN THE GALACTIC QUADRANT, '~a'.~%" qq))
(t
(format t "~%NOW ENTERING ~a QUADRANT . . .~%" qq))))
(defun repo-entering-quad-stat ()
(when (/= *c-klingons* 0)
(format t " COMBAT AREA CONDITION RED ~%"))
(when (<= *shield* 200)
(format t " SHIELDS DANGEROUSLY LOW ~%")))
(defun enter-quad1 ()
(let ((g (aref *ggg* *qx* *qy*)))
(setq *c-klingons* (quad-klingon g))
(setq *c-bases* (quad-base g))
(setq *c-stars* (quad-star g))))
(defun energy-check()
(if (and (> (+ *shield* *energy*) 10)
(or (> *energy* 10) (zerop (aref *ddd* 7))))
(return-from energy-check t))
(format t "** FATAL ERROR **~%")
(format t "YOU'VE JUST STRANDED YOUR SHIP IN SPACE.~%")
(format t "YOU HAVE INSUFFICIENT MANEUVERING ENERGY,~%")
(format t "AND SHIELD CONTROL IS PRESENTLY INCAPABLE OF~%")
(format t "CROSS-CIRCUITING TO ENGINE ROOM!!~%")
nil
; PRINT:GOTO 6220
)
(defun help-com ()
(format t "ENTER ONE OF THE FOLLOWING:~%")
(format t "--------------------------~%")
(format t " W (WARP)~%")
(format t " S (FOR SHORT RANGE SENSOR SCAN)~%")
(format t " L (FOR LONG RANGE SENSOR SCAN)~%")
(format t " P (TO FIRE PHASERS)~%")
(format t " T (TO FIRE PHOTON TORPEDOES)~%")
(format t " Z (TO RAISE OR LOWER SHIELDS)~%")
(format t " R (FOR DAMAGE CONTROL REPORTS)~%")
(format t " C (TO CALL ON LIBRARY-COMPUTER)~%")
(format t " XXX (TO RESIGN YOUR COMMAND)~%")
(format t " (zzz break for debug)~%"))
(defvar *sec* nil)
(defun init-sector()
(let (x y k)
(setq *sec* (make-array '(8 8) :initial-element nil))
(setf (aref *sec* *ex* *ey*) 'e)
(dotimes (i 4) (setf (klingon-energy(aref *kkk* i)) 0))
(dotimes (i *c-klingons*)
(loop
(setq x (fnrand))
(setq y (fnrand))
(when (not(aref *sec* x y))
(setq k (aref *kkk* i))
(setf (klingon-x k) x)
(setf (klingon-y k) y)
(setf (klingon-energy k) (* +klingon-max-energy+ (+ 5(random 10)) 0.1))
(setf (aref *sec* x y) 'k)
(return))))
(dotimes (i *c-bases*)
(loop
(setq x (fnrand))
(setq y (fnrand))
(when (not(aref *sec* x y))
(setq *bx* x)
(setq *by* y)
(setf (aref *sec* x y) 'b)
(return))))
(dotimes (i *c-stars*)
(loop
(setq x (fnrand))
(setq y (fnrand))
(when (not(aref *sec* x y))
(setf (aref *sec* x y) 's)
(return))))))
(defun mloop()
(let (#|klatt|# aaa)
(loop
;1990
(when (or *success* (<= *klingon-total* 0))
(return-from mloop (success)))
(when (> *time* (+ *time0* *t-period*))
(return-from mloop (fail-mission)))
(when *mission-end*
(return-from mloop))
(when *klingon-attack*
(klingon-attack)
(setq *klingon-attack* nil))
(when (not(energy-check))
(fail-mission)
(return-from mloop nil))
(format t "~%COMMAND")
(setq aaa (read))
(case aaa
(w
(if(not(nav)) (return-from mloop nil)))
(s (short-range-sensor))
(l (long-range-sensor))
(p (phaser))
((t) (torpedo))
(z (shield))
(r (damage-report))
(c (computer))
(xxx (end-of-mission))
(zzz (break))
(t (help-com)))
)
))
(defun nav()
(let (c1 n w1)
(when (not (setq c1 (input-course "LT. SULU"))) (return-from nav t))
;(format t "c1=~a~%" c1)
(when (not (setq w1 (nav-factor))) (return-from nav t))
;(format t "w1=~a~%" w1)
(when (not (setq n (nav-energy w1))) (return-from nav t))
;(format t "n=~a~%" n)
(klingon-attack-warp)
(repair-by-warp w1)
(damage-by-warp)
(when (not (nav4 c1 n w1)) (return-from nav t))
(warp-time w1)
))
(defun warp-time (w1)
(let ((t8 1))
(if (< w1 1) (setq t8 (/ (floor (* 10 w1)) 10)))
(incf *time* t8)
(cond
((> *time* (+ *time0* *t-period*))
(fail-mission))
(t t))))
(defun input-course (man &aux c1)
(format t "COURSE (0-8, -1)")
(setq c1 (read))
(cond
((not(numberp c1)) nil)
((= c1 -1) nil)
(t
(cond
((or (< c1 0) (> c1 8))
(format t " ~a: 'INCORRECT COURSE DATA, SIR!'" man)
t)
(t
(if(= c1 8)
0
c1))))))
(defun nav-factor ()
(let* (
(wdamage (aref *ddd* 1))
(x (if (< wdamage 0) 0.2 8))
w1)
(format t "WARP FACTOR (0-~a)" x)
(setq w1 (read))
(cond
((not(numberp w1)) nil)
((= w1 0) nil)
((and (< wdamage 0)(> w1 0.2))
(format t "WARP ENGINES ARE DAMAGED. MAXIUM SPEED = WARP 0.2")
nil)
((or (< w1 0)(> w1 8))
(format t " CHIEF ENGINEER SCOTT: 'THE ENGINES WON'T TAKE WARP~a!'" w1)
nil)
(t w1))))
(defun nav-energy (w1)
(let (
(n (floor (+(* w1 8) 0.5))))
(cond
((< *energy* n)
(format t"ENGINEERING: 'INSUFFICIENT ENERGY AVAILABLE~%")
(format t" FOR MANEUVERING AT WARP~a!'~%" w1)
(cond
((or (< *shield* (- n *energy*)) (< (aref *ddd* 7) 0))
t)
(t
(format t"DEFLECTOR CONTROL ROOM: ~a UNITS OF ENERGY" *shield*)
(format t" PRESENTLY DEPLOYED TO SHIELDS.")))
t)
(t n))))
(defun klingon-attack-warp()
(dotimes (i 4)
(cond
((/= 0 (klingon-energy (aref *kkk* i)))
;(format t "k-att move ~a~%" i)
(klingon-rand-move i))))
(klingon-attack))
(defun repair-by-warp(w1 &aux ii)
(declare (ignore w1))
(let ((flag nil) x)
(dotimes (i 9)
(setq ii (1+ i))
(cond
((<(aref *ddd* ii) 0)
(setq x (incf (aref *ddd* ii)))
(cond
((>= x 0)
(setf (aref *ddd* ii) 0)
(cond
((not flag)
(format t "DAMAGE CONTROL REPORT: ")
(setq flag t)))
(format t "~a REPAIR COMPLETED.~%" (device-name ii)))))))))
(defun damage-by-warp()
(let (damdev)
(cond
((<= (random 10) 2)
(setq damdev (rnd1-8))
(incf (aref *ddd* damdev)
(cond
((<(random 10) 6)
(format t "DAMAGE CONTROL REPORT: ~a DAMAGED~%"
(device-name damdev))
(* -1 (1+ (/(random 500)100))))
(t
(format t "DAMAGE CONTROL REPORT: ~a STATE OF REPAIR IMPROVED~%"
(device-name damdev))
(1+ (/(random 300)100)))))))))
(defun cal-vec (va c1)
(let (ci cr)
(setq ci(floor c1))
(setq cr (- c1 ci))
(+ (aref va ci)
(* (- (aref va (+ ci 1)) (aref va ci))
cr))))
(defun nav4 (c1 n w1)
(let
(
(x *ex*) (y *ey*)
(dx (cal-vec *cx* c1))
(dy (cal-vec *cy* c1))
(x0 *ex*) (y0 *ey*) (old-qx *qx*) (old-qy *qy*))
(setf (aref *sec* *ex* *ey*) nil)
(dotimes (i n)
(incf x dx)(incf y dy)
(setq *ex* (floor (+ x 0.5)))
(setq *ey* (floor (+ y 0.5)))
(cond
((or (< *ex* 0)(> *ex* 7)
(< *ey* 0)(> *ey* 7))
(return-from nav4
(cond ((exit-quad n x0 y0 dx dy w1 old-qx old-qy)
(enter-quad) t)
(t nil))))
(t (format t "(~a,~a)" *ex* *ey*)))
(when(aref *sec* *ex* *ey*)
(setq *ex* (floor(- x dx)))
(setq *ey* (floor(- y dy)))
(format t "~%WARP ENGINES SHUT DOWN AT ")
(format t "SECTOR ~a , ~a DUE TO BAD NAVAGATION" *ex* *ey*)
(return)))
(setf (aref *sec* *ex* *ey*) 'E)
(dec-energy n)
(format t "~%")
(short-range-sensor)
t))
(defun exit-quad (n x y x1 y1 w1 old-qx old-qy)
(let ((flag nil))
(incf x (+ (* 8 *qx*) (* n x1)))
(incf y (+ (* 8 *qy*) (* n y1)))
(setq *qx* (floor (/ x 8)))
(setq *qy* (floor (/ y 8)))
(setq *ex* (floor (- x (* *qx* 8))))
(setq *ey* (floor (- y (* *qy* 8))))
(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))
(cond (flag
(format t "LT. UHURA: MESSAGE FROM STARFLEET COMMAND --~%")
(format t
" 'PERMISSION TO ATTEMPT CROSSING OF GALACTIC PERIMETER~%")
(format t " IS HEREBY *DENIED*. SHUT DOWN YOUR ENGINES.'~%")
(format t "CHIEF ENGINEER SCOTT: 'WARP ENGINES SHUT DOWN~%")
(format t " AT SECTOR ~a , ~a OF QUADRANT ~a , ~a.'~%"
*ex* *ey* *qx* *qy*)
(setf (aref *sec* *ex* *ey*) 'E)
(when (> *time* (+ *time0* *t-period*))
(fail-mission)
nil))
(t
(cond
((and (eql *qx* old-qx)(eql *qy* old-qy))
(warp-time w1))
(t
(incf *time*)
(dec-energy n)
t))))))
;;; dec energy
(defun dec-energy (n)
(when (< (decf *energy* (+ n 10)) 0)
(format t "SHIELD CONTROL SUPPLIES ENERGY TO COMPLETE THE MANEUVER.~%")
(incf *shield* *energy*)
(setq *energy* 0)
(when (<= *shield* 0)
(setq *shield* 0))))
;;; Long sensor
;4000
(defun long-range-sensor()
(let (x y qqq)
(cond
((<(aref *ddd* 3) 0)
(format t "LONG RANGE SENSORS ARE INOPERABLE.~%"))
(t
(format t "LONG RANGE SCAN FOR QUADRANT ~a,~a~%" *qx* *qy*)
(dotimes (i 3)
(dotimes (j 3)
(setq x (+ *qx* i -1))
(setq y (+ *qy* j -1))
(cond
((and (>= x 0)(<= x 7)(>= y 0)(<= y 7))
(setq qqq (aref *ggg* x y))
(setf (quad-visit qqq) t)
(format t " ~1a~1a~1a"
(quad-klingon qqq)
(quad-base qqq)
(quad-star qqq)))
(t (format t " ***"))))
(format t "~%"))))))
(defun noememy()
(format t "SCIENCE OFFICER SPOCK: 'SENSORS SHOW NO ENEMY SHIPS~%")
(format t " IN THIS QUADRANT'"))
;;; phaser
;4260
(defun phaser()
(cond
((<(aref *ddd* 4) 0)
(format t "PHASERS INOPERATIVE.~%"))
(t
(cond
((<= *c-klingons* 0)
(noememy))
(t (phaser1))))))
(defun phaser1 ()
(let (x)
(cond
((<(aref *ddd* 8) 0)
(format t "COMPUTER FAILURE HAMPERS ACCURACY.~%"))
(t
(format t "PHASERS LOCKED ON TARGET; ")))
(cond
((setq x (phaser3))
(phaser4 x)))))
(defun phaser3 ()
(let (x)
(loop
(format t "PHASERS LOCKED ON TARGET; ")
(format t "ENERGY AVAILABLE = ~a UNITS~%" *energy*)
(format t "NUMBER OF UNITS TO FIRE ?")
(setq x (read))
(cond
((not(numberp x))(return-from phaser3 nil))
((<= x 0)
(return-from phaser3 nil))
(t
(cond
((>= (- *energy* x) 0)
(return-from phaser3 x))))))))
(defun phaser4 (x)
(let (h ke kx ky k h1)
(decf *energy* x)
(cond
((<(aref *ddd* 8) 0)
(setq x (random x))))
(setq h1 (floor (/ x *c-klingons*)))
(setq *klingon-attack* t)
(dotimes (i 4)
(setq k (aref *kkk* i))
(setq kx (klingon-x k))
(setq ky (klingon-y k))
(cond
((> (klingon-energy k) 0)
(setq h (floor (* (/ h1 (klingon-distance i)) (+ 2 (/(random 10)10)))))
(cond
((<= h (* (klingon-energy k) 0.15))
(format t "SENSORS SHOW NO DAMAGE TO ENEMY AT ~a , ~a.~%"
kx ky))
(t
(setq ke (decf (klingon-energy k) h))
(format t "~a UNIT HIT ON KLINGON AT SECTOR ~a,~a.~%" h kx ky)
(cond
((<= ke 0)
(delete-klingon i))
(t
(format t " (SENSORS SHOW ~3,2f UNITS REMAINING)~%" ke))))))))))
(defun delete-star (x y)
(setf (aref *sec* x y) nil)
(decf (quad-star(aref *ggg* *qx* *qy*))))
(defun delete-klingon(i)
(let (kx ky k)
(setq k (aref *kkk* i))
(setq kx (klingon-x k))
(setq ky (klingon-y k))
(format t "*** KLINGON DESTROYED ***~%")
(decf *c-klingons*)
(decf *klingon-total*)
(setf (aref *sec* kx ky) nil)
(setf (klingon-energy k) 0)
(decf (quad-klingon(aref *ggg* *qx* *qy*)))))
(defun delete-klingon-xy (x y)
(let (k)
(dotimes (i 4)
(setq k (aref *kkk* i))
(cond
((and
(/= (klingon-energy k) 0)
(= (klingon-x k) x)
(= (klingon-y k) y))
(delete-klingon i)
(return))
(t nil)))))
(defun delete-base (x y)
(let ()
(decf *c-bases*)
(decf *base-total*)
(setf (aref *sec* x y) nil)
(decf (quad-base(aref *ggg* *qx* *qy*)))))
(defun torpedo ()
(let (c1 #|obj|#)
(cond
((<= *torpedo* 0)
(format t "ALL PHOTON TORPEDOES EXPENDED.~%"))
((< (aref *ddd* 5) 0)
(format t "PHOTON TUBES ARE NOT OPERATIONAL.~%"))
(t
(format t "PHOTON TORPEDO ")
(when (not (setq c1 (input-course "ENSIGN CHEKOV")))
(return-from torpedo t))
; (format t "c1=~a~%" c1)
(decf *energy* 2)
(decf *torpedo* 1)
(torpedo-fire c1)
(setq *klingon-attack* t)))
t))
(defun torpedo-fire(c1)
(let ((x *ex*) (y *ey*) x1 y1 x3 y3 obj)
(setq x1 (cal-vec *cx* c1))
(setq y1 (cal-vec *cy* c1))
(format t "TORPEDO TRACK:")
(loop
(incf x x1)
(incf y y1)
(setq x3 (floor (+ x 0.5)))
(setq y3 (floor (+ y 0.5)))
(cond
((or (< x3 0) (> x3 7) (< y3 0)(> y3 7))
(format t "~%TORPEDO MISSED.~%")
(return))
((eql (setq obj (aref *sec* x3 y3)) 'k)
(format t "~%")
(delete-klingon-xy x3 y3)
(when (<= *klingon-total* 0)
(setq *success* t)
(throw 'game-end t))
(return))
((eql obj 's)
(format t "~%STAR AT ~a, ~a ABSORBED TORPEDO ENERGY.~%" x3 y3)
(delete-star x3 y3)
(return))
((eql obj 'b)
(format t "~%*** STARBASE DESTROYED ***~%")
(delete-base x3 y3)
(destroy-base)
(return)))
(format t "(~a,~a)" x3 y3))))
(defun destroy-base ()
(cond
((or (> *base-total* 0) (> *klingon-total* (- *time* *time0* *t-period*)))
(format t "STARFLEET COMMAND REVIEWING YOUR RECORD TO CONSIDER")
(format t "COURT MARTIAL!")
(setq *docked* nil)
(setq *klingon-attack* t))
(t
(format t "THAT DOES IT, CAPTAIN!! YOU ARE HEREBY RELIEVED OF COMMAND")
(format t "AND SENTENCED TO 99 STARDATES AT HARD LABOR ON CYGNUS 12!!")
(end-of-mission))))
;;; shield
;5530
(defun shield()
(let (x #|y|#)
(cond
((<(aref *ddd* 7) 0)
(format t "SHIELD CONTROL INOPERABLE.~%"))
(t
(format t "ENERGY AVAILABLE =~a. NUMBER OF UNITS TO SHIELDS ?"
(+ *energy* *shield*))
(setq x (read))
(cond
((or (< x 0) (= x *shield*))
(format t "<SHIELDS UNCHANGED>~%"))
((> x (+ *energy* *shield*))
(format t "SHIELD CONTROL: 'THIS IS NOT THE FEDERATION TREASURY.'" )
(format t "<SHIELDS UNCHANGED>"))
(t
(incf *energy* (- *shield* x))
(setq *shield* x)
(format t "DEFLECTOR CONTROL ROOM:")
(format t " 'SHIELDS NOW AT ~a UNITS PER YOUR COMMAND.'" *shield*)))))))
;;; damage report
;5690
(defun damage-report()
(cond
((< (aref *ddd* 6) 0)
(format t "DAMAGE CONTROL REPORT NOT AVAILABLE.~%"))
(t
(show-stat-repair)))
(docked-repair))
(defun show-stat-repair()
(format t "DEVICE STATE OF REPAIR~%")
(format t "------ ---------------~%")
(dotimes (i 8)
(format t "~a ~3,2f~%" (device-name (1+ i))
(* (floor (* 100 (aref *ddd* (1+ i)))) 0.1))))
(defun docked-repair()
(let (d3)
(cond
(*docked*
(setq d3 0)
(dotimes (i 8)
(when (< (aref *ddd* (1+ i)) 0)
(incf d3 0.1)))
(cond
((= d3 0) nil)
(t (need-repair d3)))))))
(defun need-repair (d3)
(incf d3 *damage-repair-magic-number*)
(setq d3 (if (>= d3 1) 0.9 d3))
(format t "TECHNICIANS STANDING BY TO EFFECT REPAIRS TO YOUR SHIP;")
(format t "ESTIMATED TIME TO REPAIR: ~3,2f STARDATES."
(* .01 (floor (* 100 D3))))
(format t "WILL YOU AUTHORIZE THE REPAIR ORDER (Y/N)")
(cond ((eql 'y (read))
(repair-all)
(incf *time* (+ d3 0.1))
(show-stat-repair))
(t nil)))
(defun repair-all()
(dotimes (i 8)
(cond((< (aref *ddd* (1+ i)) 0)
(aset *ddd* (1+ i) 0)))))
;;; klingon attack
;6000
(defun klingon-attack(&aux r1)
(cond
((<= *c-klingons* 0) t)
(*docked*
(format t "STARBASE SHIELDS PROTECT THE ENTERPRISE.~%")
t)
(t
(dotimes (i 4)
(let* ((k (aref *kkk* i))(ke (klingon-energy k)) h)
(when (> ke 0)
(setq h (floor (*(/ ke (klingon-distance i))
(+ 2 (/(random 10)10)))))
(decf *shield* h)
(setf (klingon-energy k)(/ ke (+ 3 (/(random 10)10))))
(format t "~a UNIT HIT ON ENTERPRISE FROM SECTOR ~a,~a .~%"
h (klingon-x k)(klingon-y k))
(cond
((<= *shield* 0)
(enterprise-destroyed)
(return-from klingon-attack))
(t
(format t
" <SHIELDS DOWN TO ~a UNITS>~%" *shield* )
(when(>= h 20)
(when (and (<= (random 10) 6) (> (/ h *shield*) 0.02))
(setq r1 (rnd1-8))
(decf (aref *ddd* r1) (+ (/ h *shield*) (/ (random 50) 100)))
(format t "DAMAGE CONTROL: '~a DAMAGED BY THE HIT'"
(device-name r1))))))))))))
;;; Fail 1 energy==0 or timeout
;6220
(defun fail-mission()
(format t "IT IS STARDATE ~5,2f.~%" *time*)
(end-of-mission))
;;; Fail destroyed
;6240
(defun enterprise-destroyed ()
(format t "~%~%THE ENTERPRISE HAS BEEN DESTROYED.")
(format t " THE FEDERATION WILL BE CONQUERED.~%")
(fail-mission))
;;; end of mission
;6270
(defun end-of-mission()
(format t "THERE WERE ~a KLINGON BATTLE CRUISERS LEFT AT~%" *klingon-total*)
(format t "THE END OF YOUR MISSION.~%")
(setq *mission-end* t)
(throw 'game-end nil))
(defun more-mission ()
(cond
((/= *base-total* 0)
(format t "~%THE FEDERATION IS IN NEED OF A NEW STARSHIP COMMANDER~%")
(format t "FOR A SIMILAR MISSION -- IF THERE IS A VOLUNTEER,~%")
(format t "LET HIM STEP FORWARD AND ENTER 'AYE'" )
(eql 'aye (read)))
(t nil)))
;;; success
;6370
(defun success ()
(let ((x (/ *klingon-org* (- *time* *time0*))))
(format t "CONGRATULATIONS, CAPTAIN! THE LAST KLINGON BATTLE CRUISER~%")
(format t "MENACING THE FEDERATION HAS BEEN DESTROYED.~%~%")
(format t "YOUR EFFICIENCY RATING IS ~s"
(* x x 1000))))
;;;
;6430
(defvar *condi* nil)
(defun dockedp()
(let (x y)
(dotimes (i 3)
(dotimes (j 3)
(setq x (+ *ex* i -1))
(setq y (+ *ey* j -1))
(when (and (>= x 0)(<= x 7)(>= y 0)(<= y 7)(eql 'b (aref *sec* x y)))
(setq *condi* "DOCKED")
(setq *docked* t)
(setq *energy* +full-energy+)
(setq *torpedo* +full-torpedo+)
(setq *shield* 0)
(format t "SHIELDS DROPPED FOR DOCKING PURPOSES.~%")
(return-from dockedp t))))
(setq *docked* nil)
nil))
(defun set-condition()
(cond ((not(dockedp))
(cond
((> *c-klingons* 0) (setq *condi* "*RED*"))
((< *energy* (/ +full-energy+ 10)) (setq *condi* "YELLOW"))
(t (setq *condi* "GREEN"))))))
;;;
;;; short range sensor
(defvar
*disp-info-funcs*
(list
(lambda()
(format t " STARDATE ~5,2f" (/(floor(* *time* 10)) 10)))
(lambda()
(format t " CONDITION ~a" *condi*))
(lambda()
(format t " QUADRANT ~a ~a" *qx* *qy*))
(lambda()
(format t " SECTOR ~a ~a" *ex* *ey*))
(lambda()
(format t " PHOTON TORPEDOES ~a" *torpedo*))
(lambda()
(format t " TOTAL ENERGY ~5,2f" (+ *energy* *shield*)))
(lambda()
(format t " SHIELDS ~5,2f" *shield*))
(lambda()
(format t " KLINGONS REMAINING ~a" *klingon-total*))))
; f1980
(defmacro srs() (short-range-sensor))
(defun short-range-sensor()
(let (fff)
(set-condition)
(when (<(aref *ddd* 2) 0)
(format t "*** SHORT RANGE SENSORS ARE OUT ***~%")
(return-from short-range-sensor nil))
;
(format t " +0-1-2-3-4-5-6-7-+")
(setq fff *disp-info-funcs*)
(dotimes (i 8)
(format t "~% ~a|" i)
(dotimes (j 8)
(format t "~a "
(case (aref *sec* i j)
((s) "*")
((k) "K")
((b) "B")
((e) "E")
(t "."))))
(format t "|")
; (disp-info i)
(apply (pop fff) nil)
)
(format t "~%")))
;;;
;;;
;;;
(defun comp-help()
(format t "FUNCTIONS AVAILABLE FROM LIBRARY-COMPUTER:~%")
(format t "-----------------------------------------~%")
(format t " G = CUMULATIVE GALTIC RECORD~%")
(format t " S = STATUS REPORT~%")
(format t " T = PHOTON TORPEDO DATA~%")
(format t " B = STARBASE NAV DATA~%")
(format t " N = DIRECTION/DISTANCE CALCULATOR~%")
(format t " Z = GALAXY 'REGION NAME' MAP~%"))
(defun computer()
(let (a)
(when (<(aref *ddd* 8) 0)
(format t "COMPUTER DISABLED.~%")
(return-from computer nil))
(format t "COMPUTER ACTIVE AND AWAITING COMMAND")
(setq a (read))
; (when (or (not(numberp a)) (< a 0) (> a 5))
; (comp-help)
; (return-from computer nil))
(case a
(g
(comp-galaxy-rec))
(s
(comp-stat-repo))
((t)
(comp-torpedo))
(b
(base-nav))
(n
(comp-calc))
(z
(comp-galaxy-name-map))
(t (comp-help)))))
(defun comp-galaxy-name-map()
(format t " THE GALAXY~%")
(format t " 0 1 2 3 4 5 6 7~%")
(format t " +-----+-----+-----+-----+-----+-----+-----+-----+")
(dotimes (i 8)
(format t "~%")
(dotimes (j 2)
(format t " ~20@a"
(quad-name (* j 4) i 1)))))
;galax record
(defun comp-galaxy-rec()
(let (#|x|# qqq)
(format t " COMPUTER RECORD OF GALAXY FOR QUADRANT ~a,~a~%"
*qx* *qy*)
(format t " 0 1 2 3 4 5 6 7~%")
(format t " +-----+-----+-----+-----+-----+-----+-----+-----+")
(dotimes (i 8)
(format t "~% ~a |" i)
(dotimes (j 8)
(setq qqq (aref *ggg* i j))
(cond
((quad-visit qqq)
(format t " ~1a~1a~1a "
(quad-klingon qqq)
(quad-base qqq)
(quad-star qqq)))
(t (format t " *** ")))))))
;status
(defun comp-stat-repo()
(format t " STATUS REPORT:~% -------------~%")
(format t " ~a KLINGON~a LEFT.~%" *klingon-total* (if (> *klingon-total* 1) "S" ""))
(format t " MISSION MUST BE COMPLETED IN ~5,2f STARDATES.~%"
(* (/(floor (+ *time0* *t-period* (- *time*))) 10) 10))
(cond
((> *base-total* 0)
(format t
" THE FEDERATION IS MAINTAINING ~a STARBASE~a IN THE GALAXY.~%~%"
*base-total* (if (> *base-total* 1) "S" "")))
(t
(format t "YOUR STUPIDITY HAS LEFT YOU ON YOUR OWN IN~%")
(format t " THE GALAXY -- YOU HAVE NO STARBASES LEFT!~%~%")))
(damage-report))
; torpedo cource
(defun comp-torpedo()
(cond
((<= *c-klingons* 0) (noememy))
(t
(format t "FROM ENTERPRISE TO KLINGON BATTLE CRUSER~a~%"
(if (> *c-klingons* 1) "S" ""))
(dotimes (i 4)
(cond
((> (klingon-energy (aref *kkk* i)) 0)
(comp-torpedo1 i)))))))
(defun comp-torpedo1(i)
(let* (
(k(aref *kkk* i))
(kx (klingon-x k))
(ky (klingon-y k)))
(format t "KLINGON at (~a,~a): DIRECTION = ~3,2f~%" kx ky
(calc-p2p *ex* *ey* kx ky))))
; calculator
(defun comp-calc()
(let (x0 y0 x1 y1)
(format t "DIRECTION/DISTANCE CALCULATOR:~%")
(format t "YOU ARE AT QUADRANT ~a,~a " *qx* *qy*)
(format t " SECTOR ~a,~a.~%" *ex* *ey*)
(format t "PLEASE ENTER INITIAL COORDINATES X?")
(setq x0 (read))
(format t "Y?")
(setq y0 (read))
(format t "FINAL COORDINATES X?")
(setq x1 (read))
(format t "Y?")
(setq y1 (read))
(disp-direct-dist x0 y0 x1 y1)))
(defun disp-direct-dist (x0 y0 x1 y1)
(format t "DIRECTION = ~3,2f~%"
(calc-p2p x0 y0 x1 y1))
(pr-distance (- x0 x1)(- y0 y1)))
; starbase nav data
(defun base-nav()
(cond
((= *c-bases* 0)
(format t
"MR. SPOCK: 'SENSORS SHOW NO STARBASES IN THIS QUADRANT.'~%"))
(t
(disp-direct-dist *ex* *ey*
*bx* *by*))))
(defun pr-distance(dx dy)
(format t "DISTANCE =~5,3f~%"(distance-p2p dx dy)))
(defun distance-p2p (dx dy)
(sqrt (+ (* dx dx) (* dy dy))))
(defun calc-p2p (x0 y0 x1 y1)
(let (dx dy)
(setq dx (- x1 x0))
(setq dy (- y1 y0))
(cond
((and (= dx 0)(= dy 0))
0)
((and (< dx 0)(>= dy 0))
(if (> (abs dx) (abs dy))
(calc0 0 dx dy)
(calc1 2 dx dy)))
((and (>= dx 0)(>= dy 0))
(if (< (abs dx)(abs dy))
(calc1 2 dx dy)
(calc2 4 dx dy)))
((and (>= dx 0)(< dy 0))
(if (> (abs dx)(abs dy))
(calc2 4 dx dy)
(calc3 6 dx dy)))
((and (< dx 0)(< dy 0))
(if (< (abs dx)(abs dy))
(calc3 6 dx dy)
(calc0 8 dx dy))))))
(defun calc0 (n dx dy)
(- n (/ dy dx)))
(defun calc1 (n dx dy)
(+ n (/ dx dy)))
(defun calc2 (n dx dy)
(calc0 n dx dy))
(defun calc3 (n dx dy)
(calc1 n dx dy))
;;; random move
(defun klingon-rand-move (i)
(let (x y
newx newy xxx
(k (aref *kkk* i)))
;(format t "i=~a~%" i)
(setq x (klingon-x k))
(setq y (klingon-y k))
;(format t "x=~a y=~a~%" x y)
(loop
(setq newx (randmove-vec x))
(setq newy (randmove-vec y))
;(format t "newx=~a newy=~a~%" newx newy)
(setq xxx (aref *sec* newx newy))
;(format t "xxx=~a~%" xxx )
(when (or (null xxx) (eql 'k xxx))
(return)))
(cond
((null xxx)
;(format t "aset2 x=~a y=~a~%" x y )
(aset2 *sec* x y nil)
(aset2 *sec* newx newy 'k)
(setf (klingon-x k) newx)
(setf (klingon-y k) newy)
(format t "Klingon at ~a,~a moves to ~a,~a~%" x y newx newy)))))
(defun randmove-vec(x)
(let (new
(d (1- (random 3))))
(setq new (+ x d))
(if (< new 0) (setq new 0))
(if (> new 7) (setq new 7))
new))
;;;
;;; device name
;;;
(defvar *device-name*
(make-array
'9 :initial-contents
'("" "WARP ENGINES" "SHORT RANGE SENSORS" "LONG RANGE SENSORS"
"PHASER CONTROL" "PHOTON TUBES" "DAMAGE CONTROL" "SHIELD CONTROL"
"LIBRARY-COMPUTER")))
;f8790
;(defmacro device-name (x)
; `(aref *device-name* ,x))
(defun device-name (x)
(aref *device-name* x))
;;;
;;; quad name
;;;
(defvar *quad-name1*
(make-array
'8 :initial-contents
'("ANTARES" "RIGEL" "PROCYON" "VEGA"
"CANOPUS" "ALTAIR" "SAGITTARIUS" "POLLUX")))
(defvar *quad-name2*
(make-array
'8 :initial-contents
'("SIRIUS" "DENEB" "CAPELLA" "BETELGEUSE"
"ALDEBARAN" "REGULUS" "ARCTURUS" "SPICA")))
(defvar *quad-sub*
(make-array
'4 :initial-contents
'(" I" " II" " III" " IV")))
;9030
(defun quad-name(z5 z4 g5)
(concatenate 'string
(quad-name1 z5 z4)
(quad-name-sub g5 z5)))
(defun quad-name1(z5 z4)
(cond ((< z5 4)
(aref *quad-name1* z4))
(t (aref *quad-name2* z4))))
(defun quad-name-sub(g5 z5)
(if(eql g5 1)
""
(aref *quad-sub* (mod z5 4))))
;;; start game
#+:ALLEGRO-V8.0 (trek)
#| just my memo
WindowsXP
GCL (GNU Common Lisp) 2.6.6 CLtL1 Feb 10 2005 08:19:54
(:COMPILER :NUMLIB :SDEBUG :DEFPACKAGE :GNU-LD :UNEXEC :TRUNCATE_USE_C
:MINGW32 :I686 :IEEE-FLOATING-POINT :WIN32 :WINNT :GMP :GCL :AKCL
:COMMON :KCL)
---
WindowsXP
ALLEGRO-V8.0
(format t "~a" *features*)
(ALLEGRO-CL-TRIAL IDE COMMON-GRAPHICS IPV6 ACL-SOCKET HIPER-SOCKET PROFILER MULTIPROCESSING
FLAVORS LITTLE-ENDIAN GSGC COMPILER USE-STRUCTS-IN-COMPILER CLOS VERIFY-CAR-CDR DYNLOAD DLWIN
X86 MSWINDOWS MICROSOFT MICROSOFT-32 ENCAPSULATING-EFS RELATIVE-PACKAGE-NAMES MODULE-VERSIONS
IEEE IEEE-FLOATING-POINT CONFORMING-IEEE ICS COMMON-LISP ANSI-CL DRAFT-ANSI-CL-2 X3J13 ALLEGRO
EXCL FRANZ-INC ALLEGRO-VERSION>= ALLEGRO-VERSION= NEW-ENVIRONMENTS OS-THREADS PROCESS7
SYMBOL-VALUE-VECTOR DYNLOAD-ACL-LIBRARY ALLEGRO-V8.0 SSL-SUPPORT)
---
FreeBSD gedanken.axe-inc.co.jp 5.4-RELEASE FreeBSD 5.4-RELEASE #0
GCL (GNU Common Lisp) 2.6.5 CLtL1 Apr 4 2005 11:14:09
*features*
(:COMPILER :NUMLIB :SDEBUG :DEFPACKAGE :GNU-LD :UNEXEC :READLINE
:TRUNCATE_USE_C :BSD :FREEBSD5.4 :I386 :SGC :IEEE-FLOATING-POINT
:UNIX :GMP :GCL :AKCL :COMMON :KCL)
---
Darwin takeBook.local 7.9.0 Darwin Kernel Version 7.9.0: Wed Mar 30 20:11:17 PS\T 2005; root:xnu/xnu-517.12.7.obj~1/RELEASE_PPC Power Macintosh powerpc
CLISP
(:CLOS :LOOP :COMPILER :CLISP :ANSI-CL :COMMON-LISP :LISP=CL :INTERPRETER
:SOCKETS :GENERIC-STREAMS :LOGICAL-PATHNAMES :SCREEN :GETTEXT :UNICODE
:BASE-CHAR=CHARACTER :UNIX)
---
FreeBSD gweep.axe-inc.co.jp 2.2.8-STABLE FreeBSD 2.2.8-STABLE #0
GCL (GNU Common Lisp) Version(2.0) Thu Mar 7 06:44:49 PST 1996
(:COMPILER :NUMLIB :SDEBUG TRUNCATE_USE_C BSD CLX-LITTLE-ENDIAN
|FreeBSD| 386BSD SGC IEEE-FLOATING-POINT UNIX GCL AKCL COMMON KCL)
|#
;;; EOF
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment