A walk through the apartment

the-apartment.lisp

(defparameter *nodes* '((balcony (you are on the balcony. a cool wind sways the blossoming trees.))
                        (lounge-room (a catto snoozes on the lounge.))
                        (kitchen (bread is proofing on the counter.))
                        (office (clothes are hung up to dry.))
                        (bathroom (small stones litter the tiled floor.))
                        (bedroom (a few articles of clothing lay on the floor.))))


(defparameter *edges* '((balcony (lounge-room inside door))
                        (lounge-room (balcony outside door)
                                     (kitchen south hallway)
                                     (office north door))
                        (kitchen (lounge-room north hallway)
                                 (bedroom south doorway)
                                 (bathroom across doorway))
                        (office (lounge-room south door))
                        (bedroom (kitchen across doorway)
                                 (bathroom nearby door))
                        (bathroom (kitchen across doorway)
                                  (bedroom nearby door))
))

(defparameter *objects* '(phone teacup laptop alarmclock succulent toothbrush))

(defparameter *object-locations* '((phone lounge-room)
                                  (teacup kitchen)
                                  (laptop office)
                                  (alarmclock bedroom)
                                  (succulent balcony)
                                  (toothbrush bathroom)))

(defparameter *location* 'lounge-room)

(defun describe-location (location nodes)
    (cadr (assoc location nodes)))

(defun describe-path (edge)
    `(there is a ,(caddr edge) going ,(cadr edge) from here.))

(defun describe-paths (location edges)
    (apply #'append (mapcar #'describe-path (cdr (assoc location edges)))))

(defun objects-at (loc objs obj-locs)
    (labels ((at-loc-p (obj)
        (eq (cadr (assoc obj obj-locs)) loc)))
    (remove-if-not #'at-loc-p objs)))

(defun describe-objects (loc objs obj-loc)
    (labels ((describe-obj (obj)
                `(you see a ,obj on the floor.)))
        (apply #'append (mapcar #'describe-obj (objects-at loc objs obj-loc)))))

(defun look ()
    (append (describe-location *location* *nodes*)
            (describe-paths *location* *edges*)
            (describe-objects *location* *objects* *object-locations*)))

(defun walk (direction)
    (let ((next (find direction
                    (cdr (assoc *location* *edges*))
                    :key #'cadr)))
    (if next 
        (progn (setf *location* (car next))
            (look))
        '(you cannot go that way.))))

(defun pickup (object)
    (cond ((member object
                (objects-at *location* *objects* *object-locations*))
            (push (list object 'body) *object-locations*)
                `(you are now carrying the ,object))
            (t '(you cannot pick that up.))))

(defun inventory ()
    (cons 'items- (objects-at 'body *objects* *object-locations*)))

(defparameter *allowed-commands* '(look walk pickup inventory))

(defun game-repl() 
    (let ((cmd (game-read)))
        (unless (eq (car cmd) 'quit)
            (game-print (game-eval cmd))
            (game-repl))))

(defun game-read ()
    (let ((cmd (read-from-string
        (concatenate 'string "(" (read-line) ")"))))
    (flet ((quote-it (x)
                (list 'quote x)))
        (cons (car cmd) (mapcar #'quote-it (cdr cmd))))))

(defun game-eval (sexp)
    (if (member (car sexp) *allowed-commands*)
        (eval sexp)
    '(i do not know that command.)))

(defun tweak-text (lst caps lit)
    (when lst
    (let ((item (car lst))
          (rest (cdr lst)))
    (cond ((eql item #\space) (cons item (tweak-text rest caps lit)))
          ((member item '(#\! #\? #\.)) (cons item (tweak-text rest t lit)))
          ((eql item #\" ) (tweak-text rest caps (not lit)))
          (lit (cons item (tweak-text rest nil lit)))
          (caps (cons (char-upcase item) (tweak-text rest nil lit)))
          (t (cons (char-downcase item) (tweak-text rest nil nil)))))))

(defun game-print (lst)
    (princ (coerce (tweak-text (coerce (string-trim "() "
                                                     (prin1-to-string lst))
                                        'list)
                                t
                                nil)
                    'string))
    (fresh-line))

(print *allowed-commands*)
(game-repl)