slimey.cl

(defun prompt (handler)
  (princ #\Newline)
  (princ "> ")
  (finish-output)
  (funcall handler
	   (read-prompt (split-at #\Space
				  (coerce (string-upcase (read-line)) 'list))))
  (prompt handler))

(defun main ()
  (prompt #'eval-prompt))

(defparameter *legal-chars*
  (coerce "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890 " 'list))

(defun split-at (elem list &key (test #'eq))
  (labels ((inner (elem list word words)
	     (if (null list)
		 (reverse (if (null word) words (cons (reverse word) words)))
		 (if (not (null (find (car list) *legal-chars*)))
		     (if (funcall test elem (car list))
			 (inner elem (cdr list) '()
				(cons (reverse word) words))
			 (inner elem (cdr list) (cons (car list) word) words))
		     '()))))
    (inner elem list '() '())))

(defun read-prompt (list)
  (if (null list)
      '()
      (cons (read-word (car list))
	    (read-prompt (cdr list)))))

(defun read-word (list)
  (if (every #'digit-char-p list)
      (read-from-string (coerce list 'string))
      (intern (coerce list 'string))))
      
(defparameter *rooms*
  `((quarry . (a large stone quarry))
    (estate . (a large lawn outside a large house))))

(defparameter *current-room* 'quarry)

(defparameter *connections*
  `((quarry . ((north . estate)))
    (estate . ((south . quarry)))))

(defparameter *inventory*
  `(tickets))

(defparameter *objects*
  `((tickets . (a set of tickets to a skinny puppy concert))
    (magnum . (a giant pistol for people with giant hands))))

(defparameter *people*
  `((cocainist . (the terrible cocainist is here
		      doing line after line of cocaine))))

(defparameter *people-locations*
  `((cocainist . livingroom)))

(defparameter *object-locations*
  `((magnum . estate)))

(defun at-random (list)
  (nth (random (length list)) list))

(defun behave-cocainist (person)
  (princln `(the cocainist dances a little jig in his pointy black shoes)))

(defun add-object (name)
  (if (null (assoc name *objects*))
      (push (cons name `(an unfinished object)) *objects*)))

(defun inventory ()
  (print-uppercase 'you)
  (mapcar #'print-lowercase `(are carrying))
  (princ ": ")
  (print-name-list *inventory*))

(defun print-name-list (ln)
  (if (> (length ln) 1)
      (mapcar (lambda (proper-name)
		(mapcar (lambda (word)
			  (print-lowercase word)
			  (princ #\Space))
			proper-name))
	      (mapcar (lambda (name)
			(process-name name))
		      (butlast ln))))
  (if (>= (length ln) 2)
      (princ 'and)
      (princ #\Space))
  (mapcar (lambda (word)
	    (print-lowercase word)
	    (princ #\Space))
	  (process-name (last ln))))

(defun valid-things-to-look-at ()
  (append *inventory*
	  (mapcar #'car
		  (remove-if-not (lambda (pair)
				   (eq *current-room* (cdr pair)))
				 *object-locations*))))

(defun look-at (object)
  (if (not (null (find object (valid-things-to-look-at))))
      (princln (cdr (assoc object *objects*)))
      (princln `(you cannot see that here))))
		  
(defun princln (list)
  (labels ((inner (list)
	     (if (null list)
		 nil
		 (progn (print-lowercase (car list))
			(princ #\Space)
			(inner (cdr list))))))
    (if (null list)
	nil
	(progn (print-uppercase (car list))
	       (princ #\Space)
	       (inner (butlast (cdr list)))
	       (print-lowercase (last list))
	       (princ #\.)
	       (princ #\Newline)))))

(defun represent-lowercase (symbol)
  (case (type-of symbol)
    ((symbol)
     (let ((str (coerce (string symbol) 'list)))
       (coerce (mapcar #'char-downcase str) 'string)))
    ((cons)
     (represent-lowercase (car symbol)))
    (t (princ symbol))))

(defun represent-uppercase (symbol)
  (let ((str (coerce (represent-lowercase symbol) 'list)))
    (coerce (cons (char-upcase (car str)) (cdr str)) 'string)))

(defun print-lowercase (symbol)
  (princ (represent-lowercase symbol)))

(defun print-uppercase (symbol)
  (princ (represent-uppercase symbol)))

(defun go-direction (direction)
  (let ((exits (assoc *current-room* *connections*)))
    (if (not (null exits))
	(let ((exit (assoc direction (cdr exits))))
	  (if (not (null exit))
	      (progn (setf *current-room* (cdr exit))
		     (princln `(you walk ,direction to the ,(cdr exit))))
	      (princln `(you cannot go that way))))
	(princln `(you see no exits from here)))))

(defun get-direction (room direction)
  (let ((exits (assoc room *connections*)))
    (if (null exits)
	nil
	(let ((exit (assoc direction (cdr exits))))
	  (if (null exit)
	      nil
	      (cdr exit))))))

(defun room-exists (room)
  (not (null (assoc room *rooms*))))

(defun room-has-exits (room)
  (not (null (assoc room *connections*))))

(defun room-exits (room)
  (mapcar #'car (cdr (assoc room *connections*))))

(defun describe-room (room description)
  (add-room room)
  (setf (cdr (assoc room *rooms*)) description))

(defun add-room (name)
  (if (not (room-exists name))
      (push (cons name `(an unfinished room)) *rooms*))
  (if (not (room-has-exits name))
      (push (cons name (list)) *connections*)))

(defun add-exit (room direction target)
  (add-room target)
  (if (not (null (get-direction room direction)))
      (setf (cdr (assoc room *connections*))
	    (cons direction target))
      (push (cons direction target)
	    (cdr (assoc room *connections*)))))

(defparameter *pronouns*
  `((quarry . the)
    (estate . a)
    (magnum . a)
    (tickets . pair)))

(defun pronoun (symbol pronoun)
  (if (not (null (assoc symbol *pronouns*)))
      (setf (cdr (assoc symbol *pronouns*)) pronoun)
      (push (cons symbol pronoun) *pronouns*)))

(defparameter *vocals*
  (coerce "AOUEIY" 'list))

(defun a-or-an (name)
  (if (not (null (find (car (coerce (string name) 'list)) *vocals*)))
      'an
      'a))

(defun process-name (name)
  (case (cdr (assoc name *pronouns*))
    ((the) `(the ,name))
    ((a) (cons (a-or-an name) (list name)))
    ((pair) `(a pair of ,name))
    (t (list name))))

(defun print-room-title (name)
  (let ((full-name (process-name name)))
    (princ (sgi-code 1))
    (mapcar (lambda (word)
	      (print-uppercase word)
	      (princ #\Space))
	    (butlast full-name))
    (if (> (length full-name) 1)
	(print-uppercase (last full-name)))
    (princ (sgi-code 0))
    (princ #\Newline)))

(defun look-at-room (room)
  (print-room-title room)
  (princln (cdr (assoc room *rooms*)))
  (princln (append `(you can go)
		   (let ((exits (room-exits room)))
		     (if (< (length exits) 2)
			 exits
			 (append (butlast exits)
				 (list 'and (last exits))))))))

(defparameter *aliases*
  `(((s) . (go south))
    ((n) . (go north))
    ((e) . (go east))
    ((w) . (go west))
    ((d) . (go down))
    ((u) . (go up))))

(defun process-aliases (input)
  (let ((alias (assoc input *aliases* :test 'equal)))
    (if (null alias)
	input
	(cdr alias))))

(defun sgi-code (n)
  (coerce
   (append '(#\Esc #\[)
	   (coerce (write-to-string n) 'list)
	   '(#\m)) 'string))

(defun princ-bold (n)
  (princ (sgi-code 1))
  (princ n)
  (princ (sgi-code 0)))

(defun eval-prompt (ls)
  (let ((list (process-aliases ls)))
    (if (null list)
	nil
	(case (car list)
	  ((go) (if (< (length list) 2)
		    (princln `(go in what direction?))
		    (progn (go-direction (second list))
			   (look-at-room *current-room*))))
	  ((look) (if (< (length list) 2)
		      (look-at-room *current-room*)
		      (look-at (second list))))
	  ((pronoun) (if (< (length list) 3)
			 (princln `(pronoun symbol pronoun))
			 (pronoun (second list) (third list))))
	  ((exit) (sb-ext:exit))
	  ((dig) (if (< (length list) 3)
		     (princln `(dig direction target))
		     (dig (second list) (third list))))
	  ((describe) (if (< (length list) 3)
			  (princln '(describe room))
			  (describe-room (second list) (rest (rest list)))))
	  ((inv) (inventory))
	  (t (princln `(i did not understand the command ,(car list))))))))

(defun dig (direction name)
  (add-exit *current-room* direction name)
  (princln `(you dig an exit ,direction to the ,name)))