[HOME]

startrek.lisp

(defconstant help-file "startrek.hlp")
(defconstant pict-file "startrek.pic")
(defconstant map-file "startrek.map")

(defconstant region-names 
    (list "ANTARES" "SIRUS"
	  "RIGEL" "DENEB"
	  "POCYON" "CAPELLA"
	  "VEGA" "BETENGULUSE"
	  "CANAPUS" "ALDEBARAN"
	  "ALTAIR" "REGULUS"
	  "SAGITATTARIUS" "ARCTURUS"
	  "POLLUX" "SPICA")
  "Names of the quadrants regions")

(defconstant quadrant-names (list "I" "II" "III" "IV"))

(defstruct sector 
  "Structure describing the data of each sector."
  (scannedp)
  (klingon-list)
  (starbase-list) 
  (star-list))

(defvar quadrants (make-array '(8 8)))
 
(defstruct location
  (quad-x 0)
  (quad-y 0)
  (sect-x 0)
  (sect-y 0)) 

(defvar enterprise-location (make-location))

(defvar start-klingons 0)
(defvar total-klingons 0)
(defvar total-starbases 0)

(defconstant start-energy 3000)
(defconstant start-photon-torpedoes 10)
(defconstant min-klingon-shield-energy 100)
(defconstant max-klingon-shield-energy 300)
(defconstant min-klingon-phaser-fire 50)
(defconstant max-klingon-phaser-fire 200)
(defconstant max-stars-sector 9)
(defconstant min-klingons-galaxy 7)
(defconstant max-klingons-galaxy 28)
(defconstant max-starbases-galaxy 5)
(defconstant min-days-mission 15)
(defconstant max-days-mission 45)
(defconstant start-star-date  3000)

(defvar energy start-energy)
(defvar shield-energy 0)
(defvar remaining-days nil)
(defvar end-date 0)
(defvar photon-torpedoes start-photon-torpedoes)
(defvar lost-game nil)
(defvar won-game nil)

(defvar warp-engine-status 0)
(defvar srs-sensor-status 0)
(defvar lrs-sensor-status 0)
(defvar phaser-status 0)
(defvar photon-torpedo-status 0)
(defvar damage-control-status 0)
(defvar shield-control-status 0)
(defvar library-computer-status 0)

(defun parse-number (number-string)
  (let ((number 0))
    (setf number (read-from-string number-string))
    (if (numberp number) number nil)))

(defun get-historical-name (x y)
  (concatenate 'string (nth (+ (* y 2) (if (> x 3) 1 0)) region-names) 
	       " "
	       (nth (mod x 4) quadrant-names)))

(defun display-file (file-name)
  (let ((p (parse-namestring file-name)))
    (with-open-file (s p :direction :input)
      (do ((l (read-line s) (read-line s nil 'eof)))
	  ((eq l 'eof) nil)
	(write-line l)))))

(defun setup-sectors ()
  (dotimes (j 8)
    (dotimes (i 8)
      (setf (aref quadrants i j) (make-sector)))))

(defun fill-stars ()
  (dotimes (j 8)
    (dotimes (i 8)
      (dotimes (k (1+ (random max-stars-sector)))
	(let ((x (random 8)) (y (random 8)))
	  (setf (sector-star-list (aref quadrants i j))
		(adjoin (list x y)
			(sector-star-list (aref quadrants i j))))
	  )))))

(defun fill-klingons ()
  (progn
    (setq total-klingons (+ min-klingons-galaxy
			    (random (1+ (- max-klingons-galaxy min-klingons-galaxy)))))
    (setq start-klingons total-klingons)
    (dotimes (k total-klingons)
      (let ((quad-x (random 8)) (quad-y (random 8))
	    (sect-x (random 8)) (sect-y (random 8))
	    (shield-strength (+  min-klingon-shield-energy
				 (random (- max-klingon-shield-energy
					    min-klingon-shield-energy)))))
	(setf (sector-klingon-list (aref quadrants quad-x quad-y))
	      (cons (list sect-x sect-y shield-strength)
		    (sector-klingon-list (aref quadrants quad-x quad-y))))
	))))

(defun fill-starbases ()
  (progn
    (setq total-starbases (1+ (random max-starbases-galaxy)))
    (dotimes (k total-starbases)
      (let ((quad-x (random 8)) (quad-y (random 8))
	    (sect-x (random 8)) (sect-y (random 8)))
	(setf (sector-starbase-list (aref quadrants quad-x quad-y))
	      (adjoin (list sect-x sect-y)
		      (sector-starbase-list (aref quadrants quad-x quad-y))))
	))))

(defun setup-galaxy ()
  (progn
    (setup-sectors)
    (fill-stars)
    (fill-klingons)
    (fill-starbases)
    (setf remaining-days (+ (random (- max-days-mission min-days-mission))
			    min-days-mission))
    (setf end-date (+ start-star-date remaining-days))
    ))
    

(defun setup-enterprise-location ()
  (setf enterprise-location 
    (make-location 
     :quad-x (random 8)
     :quad-y (random 8)
     :sect-x (random 8)
     :sect-y (random 8))))

(defun quadrant-matrix (quad-x quad-y)
  (let ((scan-array (make-array '(8 8) :element-type 'byte :initial-element 0))
	(klingon-list (sector-klingon-list (aref quadrants quad-x quad-y)))
	(starbase-list (sector-starbase-list (aref quadrants quad-x quad-y)))
	(star-list (sector-star-list (aref quadrants quad-x quad-y))))
    (loop for (i j) in  star-list do
	  (setf (aref scan-array i j) 1))
    (loop for (i j) in  starbase-list do
	  (setf (aref scan-array i j) 2))
    (loop for (i j) in klingon-list do
	  (setf (aref scan-array i j) 3))
    (when (and (= quad-x (location-quad-x enterprise-location))
	       (= quad-y (location-quad-y enterprise-location)))
      (setf (aref scan-array 
		  (location-sect-x enterprise-location)
		  (location-sect-y enterprise-location)) 
	4))
    scan-array))

(defun report-condition(quad-x quad-y)
  (if (> (length (sector-klingon-list (aref quadrants quad-x quad-y))) 0)
	  "*RED*"
	  "GREEN"))

(defun get-symbol (number)
  (case number
    (0 "   ")
    (1 " * ")
    (2 ">!<")
    (3 "+K+")
    (4 "<*>")))
	    
(defun report-status (quad-x quad-y line)
  (let ((here? (and (= quad-x (location-quad-x enterprise-location))
		    (= quad-y (location-quad-y enterprise-location)))))
    (case line
      (0 (format nil "Stardate           ~D" 
		 (- end-date remaining-days)))
      (1 (format nil "Condition          ~A" (report-condition quad-x quad-y)))
      (2 (if here?
	     (format nil "Quadrant           ~D , ~D"
		     (1+ (location-quad-x enterprise-location))
		     (1+ (location-quad-y enterprise-location)))
	   "Quadrant           N/A"))
      (3 (if here?
	     (format nil "Sector             ~D , ~D"
		     (1+ (location-sect-x enterprise-location))
		     (1+ (location-sect-y enterprise-location)))
	   "Sector             N/A"))
      (4 (format nil "Photon torpedoes   ~D"
		 photon-torpedoes))
      (5 (format nil "Total energy       ~D"
		 (+ shield-energy energy)))
      (6 (format nil "Shields            ~D"
		 shield-energy))
      (7 (format nil "Klingons remaining ~D"
		 total-klingons)))))

(defun short-range-sensor-scan ()
  (let* ((quad-x (location-quad-x enterprise-location))
	 (quad-y (location-quad-y enterprise-location))
	 (grid (quadrant-matrix quad-x quad-y)))
    (setf (sector-scannedp (aref quadrants quad-x quad-y)) t)
    (when (string= (report-condition quad-x quad-y) "*RED*")
      (write-line "COMBAT AREA  CONDITION RED"))
    (write-line "------------------------------")
    (dotimes (j 8)
      (write-string (get-symbol 0))
      (dotimes (i 8)
	(write-string (get-symbol (aref grid i j))))
      (write-string (get-symbol 0))
      (write-line (report-status quad-x quad-y j)))
    (write-line "------------------------------")
    nil))

(defun scan-quadrant (quad-x quad-y)
  (if (sector-scannedp (aref quadrants quad-x quad-y))
      (let ((klingons (length (sector-klingon-list 
			       (aref quadrants quad-x quad-y))))
	    (starbases (length (sector-starbase-list
				(aref quadrants quad-x quad-y))))
	    (stars (length (sector-star-list
			    (aref quadrants quad-x quad-y)))))
	(format nil "~1D~1D~1D" klingons starbases stars))
    "***"))

(defun long-range-sensor-scan ()
  (let ((quad-x (location-quad-x enterprise-location))
	(quad-y (location-quad-y enterprise-location)))
    (write-line "-------------------")
    (loop for j from (1- quad-y) to (1+ quad-y) do
	  (loop for i from (1- quad-x) to (1+ quad-x) do
		(if (and  (>= j 0) (< j 8) (>= i 0) (< i 8))
		    (progn
		      (setf (sector-scannedp (aref quadrants i j)) t)
		      (format t ": ~A " (scan-quadrant i j)))
		  (write-string ": *** ")))
	  (format *standard-output* ":~%" nil))
    (write-line "-------------------")))

(defun cumulative-galacic-record ()
  (progn
    (terpri)
    (write-line "            COMPUTER RECORD FOR GALAXY            ")
    (format *standard-output*
	    "~&            Enterprise position: ~D , ~D~%" 
	    (1+ (location-quad-x enterprise-location))
	    (1+ (location-quad-y enterprise-location)))
    (write-line "     1     2     3     4     5     6     7     8  ")
    (write-line "   ----- ----- ----- ----- ----- ----- ----- -----")
    (dotimes (j 8)
      (format *standard-output* "~&~1D  " (1+ j))
      (dotimes (i 8)
	(format *standard-output* " ~3A  " (scan-quadrant i j)))
      (terpri)
      (write-line "   ----- ----- ----- ----- ----- ----- ----- -----"))
    ))

(defun calculate-relative-location (course warp-factor)
  (progn
    (assert (or (> course 0) (< course 9)
		(> warp-factor 0) (< warp-factor 9)))
    (let* ((ratio (* (1- course) (/ pi 4)))
	   (rel-x (* (cos ratio) warp-factor))
	   (rel-y (* (sin ratio) warp-factor)))
      (multiple-value-bind (den-x rem-x) (truncate rel-x)
	(multiple-value-bind (den-y rem-y) (truncate rel-y)
	  (make-location 
	   :quad-x den-x
	   :quad-y (- den-y)
	   :sect-x (truncate (* rem-x 8))
	   :sect-y (- (truncate (* rem-y 8)))
	   ))))))
	 
(defun calculate-relative-course (pos)
  (let* ((fact-x (+ (* (location-quad-x pos) 8) (location-sect-x pos)))
	 (fact-y (- (+ (* (location-quad-y pos) 8) (location-sect-y pos))))
	 (-x? (if (< fact-x 0) t nil)) (-y? (if (< fact-y 0) t nil))
	 (cource! (if (= fact-x 0)
		      (if -y? 7 3)
		    (if (= fact-y 0)
			(if -x? 5 1)
		      (let ((rho (atan (/ (abs fact-y) (abs fact-x))))
			    (theta (if -x?
				       (if -y? pi (* 1/2 pi))
				     (if -y? (* 3/2 pi) 0))))
			(1+ (* (+ rho theta) (/ 4 pi)))))))
	 (warp-factor (/ (sqrt (+ (* fact-x fact-x) (* fact-y fact-y))) 8)))
    (list cource! warp-factor)))

(defun add-locations (first-pos second-pos)
  (let ((fact-x (+
		 (+ (* 8 (location-quad-x first-pos)) (location-sect-x first-pos))
		 (+ (* 8 (location-quad-x second-pos)) (location-sect-x second-pos))))
	(fact-y (+
		 (+ (* 8 (location-quad-y first-pos)) (location-sect-y first-pos))
		 (+ (* 8 (location-quad-y second-pos)) (location-sect-y second-pos)))))
    (multiple-value-bind (quad-x sect-x) (truncate (/ fact-x 8))
      (multiple-value-bind (quad-y sect-y) (truncate (/ fact-y 8))
	(make-location :quad-x quad-x :quad-y quad-y
		       :sect-x (* sect-x 8) :sect-y (* sect-y 8))))))

(defun sub-locations (first-pos second-pos)
  (let ((fact-x (-
		 (+ (* 8 (location-quad-x first-pos)) (location-sect-x first-pos))
		 (+ (* 8 (location-quad-x second-pos)) (location-sect-x second-pos))))
	(fact-y (-
		 (+ (* 8 (location-quad-y first-pos)) (location-sect-y first-pos))
		 (+ (* 8 (location-quad-y second-pos)) (location-sect-y second-pos)))))
    (multiple-value-bind (quad-x sect-x) (truncate (/ fact-x 8))
      (multiple-value-bind (quad-y sect-y) (truncate (/ fact-y 8))
	(make-location :quad-x quad-x :quad-y quad-y
		       :sect-x (* sect-x 8) :sect-y (* sect-y 8))))))

(defun location= (loc1 loc2)
  (let ((loc1-quad-x (location-quad-x loc1))
	(loc1-quad-y (location-quad-y loc1))
	(loc1-sect-x (location-sect-x loc1))
	(loc1-sect-y (location-sect-y loc1))
	(loc2-quad-x (location-quad-x loc2))
	(loc2-quad-y (location-quad-y loc2))
	(loc2-sect-x (location-sect-x loc2))
	(loc2-sect-y (location-sect-y loc2)))
    (and (= loc1-quad-x loc2-quad-x)
	 (= loc1-quad-y loc2-quad-y)
	 (= loc1-sect-x loc2-sect-x)
	 (= loc1-sect-y loc2-sect-y))))

(defun warp-engine-control ()
  (block warp-control
    (let ((course)
	  (warp-factor)
	  (energy-consumption)
	  (new-location))
    
      (write-string "COURSE (1-9)? ")
      (force-output)
      (setq course (ignore-errors (parse-number (read-line))))

      (unless (numberp course)
	(write-line "What??")
	(return-from warp-control nil))
      
      (unless (and (>= course 1) (<= course 9))
	(terpri)
	(write-line "Lt. Sulu reports 'incorrect course data sir!'")
	(return-from warp-control nil))
      
      (write-string "WARP FACTOR (0-8)? ")
      (force-output)
      (setq warp-factor (ignore-errors (parse-number (read-line))))
      (terpri)

      (unless (numberp warp-factor)
	(write-line "What??")
	(terpri)
	(return-from warp-control nil))
      
      (unless (and (>= warp-factor 0) (< warp-factor 9))
	(format *standard-output*		  
		"Chief engineer Scott reports 'The engines won't take warp ~D.'"
		warp-factor)
	(terpri)
	(return-from warp-control nil))
      
      (when (and (> warp-engine-status 0.85) (> warp-factor 0.2))
	(write-line "Warp-engines are damaged. Maximum speed warp 0.2")
	(terpri)
	(setq warp-factor 0.2))
      
      (setq energy-consumption (round (* warp-factor 8 2)))
      (if (< energy energy-consumption)
	  (progn
	    (format *standard-output*
		    "Engeneering reports 'Insufficient energy for manuvering at warp ~D'"
		    warp-factor)
	    (terpri)
	    (return-from warp-control nil))
	(setq energy (- energy energy-consumption)))
      
      (setq new-location
	    (add-locations enterprise-location
			   (calculate-relative-location course warp-factor)))
      
      (if (or (< (location-quad-x new-location) 0) 
	      (> (location-quad-x new-location) 7)
	      (< (location-sect-y new-location) 0)
	      (> (location-sect-y new-location) 7))
	  (progn
	    (write-line 
	     "Lt. Uhura reports message from starfleet command:")
	    (write-line 
	     "  'Permission to attempt to crossing of galactic perimiter")
	    (write-line "   is hereby *DENIED*. Shut down your engines.'")
	    (terpri)
	    (write-line 
	     "Chief engineer Scott reports 'Warp engines shut down.'")
	    (terpri)
	    (return-from warp-control nil))
	(setq enterprise-location new-location))
      )))

(defun calculate-phaser-hit(energy first-pos second-pos)
  (let* ((first-sect-x (first first-pos))
	 (second-sect-x (first second-pos))
	 (first-sect-y (second first-pos))
	 (second-sect-y (second second-pos))
	 (rel-x (- second-sect-x first-sect-x))
	 (rel-y (- second-sect-y first-sect-y))
	 (distance-sqr (+ (* rel-x rel-x) (* rel-y rel-y))))
    (if (= distance-sqr 0) (setf distance-sqr 1))
    (truncate (* (/ energy distance-sqr) (+ (random 2) 2)))))

(defun reduce-klingons (number)
  (progn
    (decf total-klingons number)
    (when (<= total-klingons 0)
      (terpri)
      (write-line
       "Congratulations captain! The last Klingon battleship that has been")
      (write-line "menacing the galaxy has been destroyed.")
      (format *standard-output*
	      "~%Your efficiencey rating is ~3,2F.~2%"
	      (* 1000 (/ start-klingons remaining-days)))
      (setf won-game t)
      )))

(defun phaser-control ()
  (block phaser
    (let ((klingon-list (sector-klingon-list 
			 (aref quadrants 
			       (location-quad-x enterprise-location)
			       (location-quad-y enterprise-location))))
	  (alotted-energy 0)
	  (selection))
      (when (not klingon-list)
	(terpri)
	(write-line 
	 "Science officer Spock reports: no enemy ships in this quadrant")
	(terpri)
	(return-from phaser nil))
    
      (when (> phaser-status .85)
	(terpri)
	(write-line "Phasers inoperative.")
	(terpri))
    
      (if (= (length klingon-list) 1)
	  (progn
	    (terpri)
	    (write-line "Phasers locked on target.")
	    (setq selection 0))
	(progn
	  (terpri)
	  (write-line "Select one of the following targets:")
	    
	  (let ((number 0))
	    (loop for (i j) in klingon-list do
		  (format *standard-output*
			  "~&Klingon ~D at ~D , ~D~%" number (1+ i) (1+ j))
		  (incf number))
	    (decf number)
	    (terpri)
	    (write-string "Selection? ")
	    (force-output)
	    (setq selection (ignore-errors (parse-number (read-line))))
	      
	    (unless (numberp selection)
	      (write-line "What??")
	      (return-from phaser nil))
	      
	    (when (or (< selection 0) (> selection number))
	      (terpri)
	      (write-line 
	       "Ensign Checkof reports 'No ship with that number'")
	      (return-from phaser nil))
	    )))
    
      (format *standard-output*
	      "~&Energy available = ~D units~%" energy)
      (write-string "Number of units to fire? ")
      (force-output)
      (setq alotted-energy (ignore-errors (parse-integer (read-line))))

      (when (or (not (numberp alotted-energy)) (< alotted-energy 0))
	(write-line "What??")
	(return-from phaser nil))

      (when (> alotted-energy energy)
	(terpri)
	(write-line 
	 "Ensign Checkof reports: 'Insufficient energy.'")
	(return-from phaser nil))
      
      (setf energy (- energy alotted-energy))
	      
      (let* ((klingon (nth selection klingon-list))
	     (enterprise-pos (list (location-sect-x enterprise-location)
				   (location-sect-y enterprise-location)))
	     (klingon-pos-x (first klingon))
	     (klingon-pos-y (second klingon))
	     (klingon-shield (third klingon))
	     (hit (calculate-phaser-hit 
		   alotted-energy enterprise-pos klingon)))
	(if (> hit (* .15 klingon-shield))
	    (progn
	      (terpri)
	      (format *standard-output*
		      "~&~D units hit Klingon at ~D , ~D~%"
		      (ceiling hit) (first klingon) (second klingon))
	      (setq klingon-shield (- klingon-shield hit))
	      (if (< klingon-shield 0)
		  (progn
		    (write-line "*** KLINGON DESTROYED ***")
		    (setq klingon-list (remove klingon klingon-list))
		    (reduce-klingons 1))
		(progn
		  (format *standard-output*
			  "  (Sensor show ~D units remaining.)~%" 
			  (ceiling klingon-shield))
		  (setf (third (nth selection klingon-list))
			klingon-shield)))

	      (setf (sector-klingon-list
		     (aref quadrants 
			   (location-quad-x enterprise-location)
			   (location-quad-y enterprise-location)))
		    klingon-list))
	  (format *standard-output*
		  "~&Sensors show no damage at ~D , ~D~%"
		  (1+ klingon-pos-x) (1+ klingon-pos-y)))
	))))

(defun enterprise-destroyed ()
  (progn
    (terpri)
    (write-line "The Enteprise has been destroyed!")
    (write-line "Soon the federation will be concured.")
    (write-line "The game is over.")
    (format *standard-output*
	    "~&At the end of the game there were ~D klingon~P remaining.~2%"
	    total-klingons total-klingons)
    (setf lost-game t)))

(defun calculate-enterprise-damage (energy-hit)
  (progn
    (when (< (- shield-energy energy-hit) 0) 
      (enterprise-destroyed)
      (return-from calculate-enterprise-damage))
    
    (when (> energy-hit (* shield-energy .15))
      (let ((damage (/ (random 100) 100))
            (system (random 8))
            (sensor-name "None"))
        (macrolet ((update (variable name)
			   `(progn (incf damage ,variable)
				   (if (> damage 1.0) (setf damage 1.0))
				   (setf ,variable damage)
				   (setf sensor-name ,name))
			   ))
	  (case system
	    (0 (update warp-engine-status "warp engines"))
	    (1 (update srs-sensor-status "short range scanner"))
	    (2 (update lrs-sensor-status "long range scanner"))
	    (3 (update phaser-status "phaser control"))
	    (4 (update photon-torpedo-status "photon torpedo control"))
	    (5 (update damage-control-status "damage control"))
	    (6 (update shield-control-status "shield control"))
	    (7 (update library-computer-status "library computer")))
	  (let ((damage-extent "damaged"))
	    (when (> damage .85)
	      (setf damage-extent "disabled"))
	    (format *standard-output*
		    "~&Damage control reports '~A ~A by the hit'~%"
		    sensor-name damage-extent))
	  ))
      (decf shield-energy energy-hit))))

(defun complete-repair-enterprise-damage ()
  (progn
    (setf warp-engine-status 0)
    (setf srs-sensor-status 0)
    (setf lrs-sensor-status 0)
    (setf phaser-status 0)
    (setf photon-torpedo-status 0)
    (setf damage-control-status 0)
    (setf shield-control-status 0)
    (setf library-computer-status 0)
    ))

(defun partial-repair-enterprise-damage ()
  (let ((repair (/ (random 100) 100)))
    (macrolet ((update (variable)
                       `(if (> ,variable 0)
			    (let ((damage (- ,variable repair)))
			      (if (< damage 0) (setf damage 0))
			      (setf ,variable damage)
			      (return-from partial-repair-enterprise-damage)))
                       ))
      (update warp-engine-status)
      (update shield-control-status)
      (update srs-sensor-status)
      (update lrs-sensor-status)
      (update phaser-status)
      (update photon-torpedo-status)
      (update damage-control-status)
      (update library-computer-status)
      )))

(defun found-klingons-quadrant ()
  (let ((klingon-list 
	 (sector-klingon-list
	  (aref quadrants 
		(location-quad-x enterprise-location)
		(location-quad-y enterprise-location))))
	)
    
    (if (> (list-length klingon-list) 0)
	t nil)))
      
(defun klingon-phaser-fire ()
  (block phaser
    (let ((klingon-list 
	   (sector-klingon-list
	    (aref quadrants 
		  (location-quad-x enterprise-location)
		  (location-quad-y enterprise-location))))
	  (enterprise-sect-x (location-sect-x enterprise-location))
	  (enterprise-sect-y (location-sect-y enterprise-location))
	  )
    
      (loop for (sect-x sect-y) in klingon-list do
	    (let ((klingon-shoots (if (= (random 2) 0) nil t)))
	      (when klingon-shoots
		(let* ((energy-fired (+ min-klingon-phaser-fire
					(random (1+
						 (- max-klingon-phaser-fire
						    min-klingon-phaser-fire)))))
		       (energy-hit (calculate-phaser-hit 
				    energy-fired
				    (list enterprise-sect-x enterprise-sect-y)
				    (list sect-x sect-y))))
		  (format *standard-output*
			  "~%~D unit hit on Enterprise from ~D, ~D~%"
			  energy-hit (1+ sect-x) (1+ sect-y))
		  (when (> (- shield-energy  energy-hit) 0)
		    (format *standard-output*
			    "~&    ~%"
			    (- shield-energy energy-hit)))
		  (calculate-enterprise-damage  energy-hit)		  
		  ))))
      )))

(defun photon-torpedo-control ()
  (block torpedo
    (unless (> photon-torpedoes 0)
      (write-line "All photon torpedoes expended.")
      (terpri)
      (return-from torpedo nil))
    
    (when (> photon-torpedo-status .85)
      (write-line "Photon tubes are not operational")
      (terpri)
      (return-from torpedo nil))
    
    (let ((course))
      (write-string "COURSE (1-9)? ")
      (force-output)
      (setq course (ignore-errors (parse-number (read-line))))

      (unless (numberp course)
	(write-line "What??")
	(return-from torpedo nil))
      
      (unless (and (>= course 1) (<= course 9))
	(terpri)
	(write-line "Ensign Checkov reports 'incorrect course data, sir!'")
	(return-from torpedo nil))

      (decf photon-torpedoes)
      (terpri)
      (write-line "Torpedo track:")
      
      (let* ((ratio (* (/ (1- course) 4) pi))
	     (step-x (cos ratio))
	     (step-y (- (sin ratio)))
	     (cur-x (location-sect-x enterprise-location))
	     (cur-y (location-sect-y enterprise-location))
	     (sector (aref quadrants
			   (location-quad-x enterprise-location)
			   (location-quad-y enterprise-location)))
	     (star-list (sector-star-list sector))
	     (starbase-list (sector-starbase-list sector))
	     (klingon-list (sector-klingon-list sector)))
	(loop
	 (setq cur-x (+ cur-x step-x))
	 (setq cur-y (+ cur-y step-y))
	  
	 (dolist (s star-list)
	   (when (and (= (first s) (round cur-x)) 
		      (= (second s) (round cur-y)))
	     (format *standard-output* 
		     "~&Star at ~D , ~D absorbed torpedo energy.~%"
		     (1+ (first s)) (1+ (second s)))
	     (terpri)
	     (return-from torpedo nil)))

	 (dolist (k klingon-list)
	   (when (and (= (first k) (round cur-x)) 
		      (= (second k) (round cur-y)))
	     (write-line "*** KLINGON DESTROYED ***")
	     (terpri)
	     (setf (sector-klingon-list
		    (aref quadrants
			  (location-quad-x enterprise-location)
			  (location-quad-y enterprise-location)))
		   (remove k klingon-list))
	     (reduce-klingons 1)
	     (return-from torpedo nil)
	     ))

	 (dolist (s starbase-list)
	   (when (and (= (first s) (round cur-x)) 
		      (= (second s) (round cur-y)))
	     (write-line "*** STARBASE DESTROYED ***")
             (setf (sector-starbase-list
                    (aref quadrants
                          (location-quad-x enterprise-location)
                          (location-quad-y enterprise-location)))
                   (remove s starbase-list))
	     (decf total-starbases)
	     (if (= total-starbases 0)
		 (progn
		   (write-line "That does it, captain!! You are hereby relieved of command")
		   (write-line "and sentencet to 99 days hard labor at Cygnus 12!")
		   (setf lost-game t)
		   (return-from torpedo nil))
	       (progn
		 (write-line 
		  "Starfleet command is reviewing your record")
		 (write-line "to consider court martial.")
		 (terpri)
		 (return-from torpedo nil)))))
	       

	 (when (or (< cur-x 0) (> cur-x 7)
		   (< cur-y 0) (> cur-y 7))
	   (write-line "Torpedo missed.")
	   (terpri)
	   (return-from torpedo nil))

	 (format *standard-output* "                ~D , ~D~%" 
		 (1+ (round cur-x)) (1+ (round cur-y)))
	 )))))

(defun shield-control ()
  (block shield
    (let ((allotted-energy 0))
      
      (when (> shield-control-status .85)
	(write-line "Shields inoperable.")
	(return-from shield nil))
      
      (format *standard-output* 
	      "~&Energy currently allotted to shields = ~D units~%" 
	      shield-energy)
      (format *standard-output* "~&Energy available = ~D units~%" energy)
      (write-string "Number of units to shields? ")
      (force-output)
      (setq allotted-energy (ignore-errors (parse-integer (read-line))))

      (when (or (not (numberp allotted-energy)) (< allotted-energy 0))
	(write-line "What??")
	(return-from shield nil))
    
      (when (= allotted-energy shield-energy)
	(write-line "")
	(return-from shield nil))

      (when (> allotted-energy (+ energy shield-energy))
	(write-line 
	 "Deflector control reports 'This is not the federation treasury'")
	(return-from shield nil))
      
      (decf energy (- allotted-energy shield-energy))
      (setf shield-energy allotted-energy)

      (write-line "Deflector control room reports:")
      (format *standard-output*
	      "'Shields are now at ~D units at your commmand.'~%"
	      shield-energy)
      shield-energy
      )))

(defun damage-control-report ()
  (progn
    (terpri)
    (write-line "Device              State of repair")
    (write-line "-----------------------------------")
    (format *standard-output*
	    "Warp engines              ~3,2F~%" warp-engine-status)
    (format *standard-output*
	    "Short range sensor        ~3,2F~%" srs-sensor-status)
    (format *standard-output*
	    "Long range sensor         ~3,2F~%" lrs-sensor-status)
    (format *standard-output*
	    "Phaser control            ~3,2F~%" phaser-status)
    (format *standard-output*
	    "Photon tubes              ~3,2F~%" photon-torpedo-status)
    (format *standard-output*
	    "Shield control            ~3,2F~%" shield-control-status)
    (format *standard-output*
	    "Damage control            ~3,2F~%" damage-control-status)
    (format *standard-output*
	    "Library computer          ~3,2F~%" library-computer-status)
    (terpri)))

(defun photon-torpedo-data ()
  (block data
    (let ((klingon-list (sector-klingon-list 
			 (aref quadrants 
			       (location-quad-x enterprise-location)
			       (location-quad-y enterprise-location)))))
      (when (= (length klingon-list) 0)
	(terpri)
	(write-line "Sensors report no klingons in this quadrant")
	(terpri)
	(return-from data nil))

      (format *standard-output*
	      "~%Distance to klingon battle cruicer~P~2%" 
	      (length klingon-list))
      
      (loop for (i j) in  klingon-list do
	    (let ((data (calculate-relative-course 
			 (sub-locations
			  (make-location 
			   :quad-x (location-quad-x enterprise-location)
			   :quad-y (location-quad-y enterprise-location)
			   :sect-x i :sect-y j)
			  enterprise-location))))

	      (format *standard-output* 
		      "~&Klingon in sector ~D , ~D~%Course = ~3,2F~%Distance= ~3,2F~2%"
		      (1+ i) (1+ j) (first data) (second data))))
      )))
	      
(defun starbase-nav-data ()
  (block data
    (let ((starbase-list (sector-starbase-list 
			  (aref quadrants 
				(location-quad-x enterprise-location)
				(location-quad-y enterprise-location)))))

      (when (= (length starbase-list) 0)
	(terpri)
	(write-line "Sensors report no starbase in this quadrant")
	(terpri)
	(return-from data nil))

      (format *standard-output*
	      "~%Distance to starbase~P~2%" 
	      (length starbase-list))
      
      (loop for (i j) in  starbase-list do
	    (let ((data (calculate-relative-course 
			 (sub-locations
			  (make-location 
			   :quad-x (location-quad-x enterprise-location)
			   :quad-y (location-quad-y enterprise-location)
			   :sect-x i :sect-y j)
			  enterprise-location))))

	      (format *standard-output* 
		      (concatenate 'string
				   "~&starbase in sector ~D , ~D"
				   "~%Course = ~3,2F~%Distance= ~3,2F~2%")
		      (1+ i) (1+ j) (first data) (second data ))))
      )))

(defun navigation-calculator ()
  (block navigation
    (terpri)
    (write-line "Navigation calculator")
    (format t "~%Current position is quadrant ~D , ~D sector ~D , ~D~2%"
	    (1+ (location-quad-x enterprise-location))
	    (1+ (location-quad-y enterprise-location))
	    (1+ (location-sect-x enterprise-location))
	    (1+ (location-sect-y enterprise-location)))
    
    (write-line "Enter quadrant coordinates")
    (let ((quad-x (progn
		    (write-string "X coordinate (1..8): ")
		    (force-output)
		    (ignore-errors (parse-integer (read-line)))))
	  (quad-y (progn
		    (write-string "Y coordinate (1..8): ")
		    (force-output)
		    (ignore-errors (parse-integer (read-line))))))

      (unless (and (numberp quad-x) (numberp quad-y))
	(write-line "What??")
	(return-from navigation nil))
      
      (when (or (< quad-x 1) (> quad-x 8)
		(< quad-y 1) (> quad-y 8))
	(terpri)
	(write-line "Not a valid quadrant.")
	(terpri)
	(return-from navigation nil))

      (let ((data (calculate-relative-course 
		   (sub-locations
		    (make-location :quad-x (1- quad-x) :quad-y (1- quad-y)
				   :sect-x 
				   (location-sect-x enterprise-location)
				   :sect-y 
				   (location-sect-y enterprise-location))
		    enterprise-location))))
	
	(format t "~%Navigation~%Course = ~3,2F~%Distance= ~3,2F~2%"
		(first data) (second data)))
      )))
	      
	      
(defun status-report ()
  (progn
    (format *standard-output* "~%Status report~%")
    (format *standard-output* "There are ~D Klingon~P left.~%" 
	    total-klingons total-klingons)
    (format *standard-output* "Mission must be completed in ~D day~P.~%"
	    remaining-days remaining-days)
    (format *standard-output* 
	    "The federation is mentaining ~D starbase~P in the galaxy.~%"
	    total-starbases total-starbases)
    nil))

(defun galactic-region-name-map ()
  (display-file map-file))

(defun library-computer ()
  (block computer
    (when (> library-computer-status .85)
      (write-line "Library computer disabled.")
      (return-from computer nil))
    (let ((command 
	   (progn 
	     (write-string "Computer active and awaiting command? ")
	     (force-output)
	     (ignore-errors (parse-integer (read-line))))))
      (case command
	(0 (cumulative-galacic-record))
	(1 (status-report))
	(2 (photon-torpedo-data))
	(3 (starbase-nav-data))
	(4 (navigation-calculator))
	(5 (galactic-region-name-map))
	(otherwise
	 (terpri)
	 (write-line "The library computer accepts the following commands:")
	 (write-line "  0  -- Cumulative galactic record")
	 (write-line "  1  -- Status report")
	 (write-line "  2  -- Photon torpedo data")
	 (write-line "  3  -- Starbase navigation data")
	 (write-line "  4  -- navigation calculator")
	 (write-line "  5  -- Galactic region name map")
	 (terpri)))
      nil)))

(defun select-command ()
  (let ((command 
	 (progn 
	   (write-string "COMMAND? ")
	   (force-output)
	   (ignore-errors (string-upcase (read-line)))))
	(quit nil))
    (cond
     ((string= command "NAV") (warp-engine-control))
     ((string= command "SRS") (short-range-sensor-scan))
     ((string= command "LRS") (long-range-sensor-scan))
     ((string= command "PHA") (phaser-control))
     ((string= command "TOR") (photon-torpedo-control))
     ((string= command "SHE") (shield-control))
     ((string= command "DAM") (damage-control-report))
     ((string= command "COM") (library-computer))
     ((string= command "XXX") (setq quit t))
     ((string= command "DEB") (progn
				(write-string "lisp: ")
				(force-output)
				(pprint (eval (read)))
				(clear-input)
				(terpri)))
     (t 
      (progn
	(write-line "NAV - navigate command")
	(write-line "SRS - short range sensor scan")
	(write-line "LRS - long range sensor scan")
	(write-line "PHA - phaser control")
	(write-line "TOR - photon torpedo control")
	(write-line "SHE - shield control")
	(write-line "DAM - damage control")
	(write-line "COM - library computer")
	(write-line "XXX - resign command"))))
    quit))

(defun describe-settings ()
  (progn
    (format *standard-output* 
	    "~2%Your instructions are as follows:" 
	    nil)
    (format *standard-output* 
	    "~%     Destroy the ~D Klingon warships which have invaded"
	    total-klingons)
    (format *standard-output*
           "~%  the galaxy before they can destroy the federation"
	    nil)
    (format *standard-output* 
	    "~%  headquarters on stardate ~D.  This gives you ~D days."
	    end-date remaining-days)
    (format *standard-output*
	    (concatenate 'string
	      "~%  There are ~D starbase~P in the galaxy for"
	      " resupplying your ship.~2%")
	    total-starbases total-starbases)
    (format *standard-output*
	    "~2%Your mission begins with your starship located"
	    nil)
    (format *standard-output*
	    "~%in the galactic quadrant '~A'.~2%"
	    (get-historical-name 
	     (1+ (location-quad-x enterprise-location))
	     (1+ (location-quad-y enterprise-location))))
    ))

(defun found-starbase-quadrant ()
  (let* ((quad-x (location-quad-x enterprise-location))
	 (quad-y (location-quad-y enterprise-location))
	 (sect-x (location-sect-x enterprise-location))
	 (sect-y (location-sect-y enterprise-location))
	 (starbase-list 
	  (sector-starbase-list (aref quadrants quad-x quad-y))))

    (if (and starbase-list
	    (find-if 
	     #'(lambda (x) (and (= (first x)  sect-x) (= (second x) sect-y)))
	     starbase-list))
	t
      nil)))

(defun dock-to-starbase ()
  (progn
    (write-line "Shields dropped for docking purposes.")
    (setf energy start-energy)
    (setf shield-energy 0)
    (setf photon-torpedoes start-photon-torpedoes)
    (complete-repair-enterprise-damage))
  )

(defun setup-paramaters ()
  (setf energy start-energy)
  (setf shield-energy 0)
  (setf lost-game nil)
  (setf won-game nil)
  (complete-repair-enterprise-damage))

(defun update-date (number)
  (decf remaining-days number)
  (when (<= remaining-days 0)
    (format *standard-output* 
	    "~2%It is stardate ~D. Your time is up!~%"
	    end-date)
    (write-line 
     "The klingon starships have now reached federation headquarters")
    (write-line "and concured the federation.")
    (write-line "The game is over.")
    (format *standard-output*
	    "~&At the end of the game there were ~D Klingon~P remaing.~2%"
	    total-klingons total-klingons)
    (setf lost-game t)
    ))

(defun play-again-p ()
  (let ((command
	 (progn
	   (write-line "The federation is in need of a new starship commander")
	   (write-line "for a simular mission -- If there is a voulenteer")
	   (write-string "let him step forward and enter 'AYE' ? ")
	   (force-output)
	   (ignore-errors (string-upcase (read-line))))))
    (if (and (stringp command) (string= command "AYE")) t nil)
    ))

(defun startrek ()
  (block main
    (terpri)
    (write-line "Welcome to StarTrek the game.")
    (terpri)
    (when (yes-or-no-p "Do you need instructions? ")
      (display-file help-file))
    (loop
     (setup-galaxy)
     (setup-enterprise-location)
     (setup-paramaters)

     (display-file pict-file)
    
     (describe-settings)
     (short-range-sensor-scan)

     (block game
       (loop
	(let ((old-location enterprise-location))
	  (when (select-command) 
	    (return-from game nil))
	
	  (unless (and
		   (= (location-quad-x enterprise-location) 
		      (location-quad-x old-location))
		   (= (location-quad-y enterprise-location)
		      (location-quad-y old-location)))
	    (format *standard-output*
		    "~2%Now entering '~A' quadrant.~2%"
		    (get-historical-name
		     (location-quad-x enterprise-location)
		     (location-quad-y enterprise-location)))

	    (partial-repair-enterprise-damage)
	    (short-range-sensor-scan)
	    (update-date 1))
	  
	  (if (found-starbase-quadrant)
	      (dock-to-starbase)
	    (when (found-klingons-quadrant)
	      (klingon-phaser-fire)))

	  (when (or won-game lost-game) (return-from game))
	  )))

     (unless (play-again-p) (return-from main nil))
     )))


startrek.hlp



		 *************************************
		 *                                   *
		 *    *  *  SUPER STAR TREK  *  *    *
		 *                                   *
		 *************************************

1. When you see \COMMAND ? \ printed, enter one of the legal commands
(NAV, SRS, LRS, FHA, TOR, SHE, DAM, COM, OR XXX).

2. If you should type a illegal command you will get a short list of
legal commands printed out.

3. Some commands require that you enter data (for example the 'NAV'
command comes back with 'COURSE (1-9) ?'.) If you type in illegal data
that command will be aborted.

The galaxy is divided into a 8 x 8 quadrant grid, and each quadrant is
further divided into a 8 x 8 sector grid.

You will be assigned a starting point somewhere in the galaxy to begin
your tour of duty as commander of the starship Enterprise; your
mission: to seek out and destroy the fleet of Klingon warships which
are menacing The United Federation of Planets.

You have the following commands available to you as captain of the
starship Enterprise:

\NAV\ command = warp engine control
    Course is in a circular numerical vector arrangement as shown. Integer
    and real values may be used. 
    (The course 1.5 is hafway between 1 and 2.)

      4  3  2
       . . . 
        ...	   
    5 ---*--- 1
        ...	 
       . . .
      6  7  8

    COURSE

    Values may approach 9.0, which itself is equivalent to 1.0.

    One warp factor is the size of one quadrant. Therefore, to get from
    quadrant 6,5 to 5,5, you would use course 3, warp factor 1.

\SRS\ command = short range sensor scan
    Shows you a scan of the present quadrant.

    Symbiology of your sensor scan is as follows:
    <*> = Your starships position
    +K+ = Klingon battle cruiser
    >!< = Federation starbase
     *  = star

    A condensed status report will altso be presented.

\LRS\ command = long range scan
    Shows conditions in space for one quadrant on each side of the
    Enterprise (which is in the middle of the scan.)
    The scan code is coded in the form \###\, where the units digit if the
    number of stars, the tens digit is the number of starbase and the
    hundreds digit is the number of Klingons.

    Example - 207 = 2 Klingons, no starbases, 7 stars

\PHA\ command = phaser control
    Allows you to destroy the klingon by zapping them with a suitably
    large unit of energy depleted from their shield power. (Remember
    Klingons have phasers too!)

\TOR\ command = photon torpedo control
    Torpedo course is the same as used in warp engine control. If you hit
    the Klingon vessel, he is destroyed and can not fire back at you. If
    you miss, you are subject to his phaser fire. In either case,
    you are altso subject to the phaser fire of all the other Klingons in
    the quadrant.

    The library computer (\COM\) has an option to compute torpedo
    tranjectory for you (option 2).

\SHE\ command = shield control
    Defines the number of energy units to be assigned to the
    shields. Energy is taken from total ships energy. Note that the status
    display total energy includes shield energy.

\DAM\ command = damage control report
    Gives the state of repairs for all devices. Where a negative 'state of
    repair' shows that the device is temporarly damaged.

\COM\ command = library-computer
    The library computer contains six options:
    option 0 = cumulative galactic record
       This option shows computer memory of all previous short and long range
       sensor scans.
    option 1 = status report
       This option shows the number of Klingons, stardates and starbases
       remaining in the game.
    option 2 = photon torpedo data
       Which gives the direction and distance from Enterprise to all Klingons
       in the quadrant.
    option 3 = starbase nav data
       This option gives the direction and distance to any starbases within
       your quadrant.
    option 4 = direction/distance calculation
       This option allows you to enter coordinates for direcion/distance 
       calculations.
    option 5 = galactic /REGION NAME/ map
       This option prints the names of the sixteen major galactic regions
       reffered to in the game.

startrek.map


		      THE GALAXY       	
     1 	   2   	 3     4     5 	   6   	 7     8

1           ANTARES                 SIRIUS
     I    II    III   IV     I    II    III   IV

2            RIGEL                   DENEB
     I    II    III   IV     I    II    III   IV

3           PROCYON                 CAPELLA
     I    II    III   IV     I    II    III   IV

4            VEGA                 BETENGULUSE
     I    II    III   IV     I    II    III   IV

5           CANAPUS                ALDEBARAN
     I    II    III   IV     I    II    III   IV

6           ALTAIR                  REGULUS
     I    II    III   IV     I    II    III   IV

7        SAGITATTARIUS              ARCTURUS
     I    II    III   IV     I    II    III   IV

8           POLLUX                   SPICA
     I    II    III   IV     I    II    III   IV

startrek.pic


			       
			       	,------------------,
       	      ,--------------- 	 '---  -----------' 
	       '-------- ----' 	   /  /	  	   
		   ,---' '--------/  /--,	   
		    '------------------'       	   
		       	      	       	
		THE USS ENTERPRISE -- NCC-1701