#|
No exposition included but try
;;(if you have gnuplot - apt install gnuplot )
(setq *circle* (encircle 6))
(require 'asdf)
(uiop:run-program (shplot *circle*))
;;Technically you could 'play'
(play *circle*)
;;But it's relatively unlikely you would lose
;;Bug: Not responding to interrupts, please
;;type quit to quit
Better versions inc
|#
(setq *print-circle* t)
(setq *room* '#1=(CURRENT (LIVING-ROOM LAMP)
(LADDER (ATTIC APPLE ORANGE) #1#)
(DOOR (GARDEN) #1#)))
(defvar *vowels* '(#\a #\e #\i #\o #\u))
(defun look (&optional (room *room*))
(let ((string-location (format nil "~(~a~)" (caadr room)))
(exits (mapcar 'car (cddr room)))
(items (cdadr room)))
(format t "I am in a~@[n~1*~] ~a~%"
(find (char string-location 0) *vowels*)
string-location)
(format t "~[No items~;One item: ~:;Items: ~] ~@[~a~]~%"
(length items) items)
(format t "Exits to: ~a~%" exits)))
(defun traverse (edge &optional (room *room*))
(let ((destination (assoc edge (cddr room))))
(cond (destination
(rplaca room edge)
(setq room destination)
(rplaca room 'current))
((null destination)
(format t "~a not found~%" edge))))
room)
(defvar *inventories* '((1 . ())))
(defun take (item-name &optional (room *room*) (player 1))
(symbol-macrolet
((inventory (cdr (assoc player *inventories*)))
(room-contents (cdadr room)))
(let ((item (find item-name room-contents)))
(if (not item) (format t "I can't take ~a~%" item-name)
(unwind-protect (push item inventory)
(setf room-contents (delete item room-contents)))))))
(defun taken (&optional (player 1))
(cdr (assoc player *inventories*)))
(defun untake (item-name &optional (room *room*) (player 1))
(symbol-macrolet
((inventory (cdr (assoc player *inventories*)))
(room-contents (cdadr room)))
(if (find item-name inventory)
(unwind-protect (push item-name room-contents)
(setf inventory (delete item-name inventory)))
(format t "I can't drop ~a~%" item-name))))
;;;; WUMPUS LAYOUT
(setq *room* '#1=(CURRENT (LIVING-ROOM LAMP)
(LADDER (ATTIC APPLE ORANGE) #1#)
(DOOR (GARDEN) #1#)))
(defun make-room (&optional (room-name (gensym)))
(let ((maze `(,(gensym) (,room-name))))
maze))
(defun connect (maze new) "
(add-room maze '(door-name (room-name item1 item2)))
"
(nconc maze (list (nconc new (list maze))))
maze)
(defun seems-to-work ()
(let ((maze (make-room)))
(prin1 (Setf maze (connect maze '(door (room))))) (terpri)
(prin1 (Setf maze (traverse 'door maze))) (terpri)
(prin1 (setf maze (connect maze '(foo (bar))))) (terpri)
(prin1 (Setf maze (traverse 'door maze))) (terpri)
(terpri)
(values maze)))
(defun example-connect-linear ()
(let ((room-1 (make-room 'room-1))
(room-2 (make-room 'room-2))
(room-3 (make-room 'room-3))
(room-4 (make-room 'room-4)))
(connect room-1 room-2)
(connect room-2 room-3)
(connect room-3 room-4)
room-1))
(defun encircle (&optional (n 4))
(let ((head (make-room)) (tail (make-room)))
(loop initially (connect head tail)
for x below n
for room = (make-room)
do (connect tail room)
do (setf tail (traverse (car room) tail))
finally (return-from encircle
(progn (connect head tail)
(traverse (car head) tail))))))
(defun list-exits (room)
(mapcar (lambda (x) (cons (car x) (caadr x)))
(cddr room)))
(defun flatten (room &optional (generation 0)
(flat-nodes (list)))
(unless (member (caadr room) flat-nodes :key 'caadr)
(setf flat-nodes (nconc flat-nodes (list room)))
(unless (zerop generation)
(dolist (node (cddr room))
(setf flat-nodes (flatten node (1- generation)
flat-nodes)))))
(values flat-nodes))
(defun circle-data (flat &optional (radius 5) &key (wumpus nil))
(let ((circle-coords
(loop for n below (length flat)
collect (mapcar
(lambda (f)
(* radius
(funcall f (* n 2 PI
(/ (length flat))))))
(list #'cos #'sin)))))
(with-output-to-string (*standard-output*)
(loop for node in flat
for coords in circle-coords for x from 0 do
(format t "~{~5,2,,'0f ~} ~a"
coords (caadr node))
do (unless (= x (1- (length flat))) (terpri))))))
(defun shplot (room &optional (radius 5) (generations 5))
(let* ((Flat (flatten room generations))
(data (circle-data flat radius)))
(format nil "gnuplot -p -e \"unset key; plot ~{~a~^, ~};\" <<EOG
~@{~a~%~^e~%~%~}
EOG" '("'-' using 1:2:(0.5) with circles"
"'-' using 1:2:3 with labels"
;;"plot '-' using 1:2:3 with labels tc rgb \"white\" offset (0,0);"
)
data data)))
(defun place-wumpus (maze &optional (generation 5))
(let* ((flat (cdr (flatten maze generation)))
(r (random (length flat)))
(wumpus (list 'wumpus)))
(loop for f in flat for x from 0
do (when (= x r)
(prin1 x) (terpri)
(prin1 f) (terpri)
(setf (cadr f) (nconc (cadr f) wumpus))
(return-from place-wumpus f)))))
(defun detect (maze)
(let* ((flat (flatten maze 2))
(invs (reduce 'append (mapcar 'cdadr flat))))
(mapc 'print invs) (terpri) invs))
(defun hunt (maze)
(loop for detect = (detect maze)
for exits = (list-exits maze)
do (format t "~a~%" (cadr maze))
do (progn (when (member 'wumpus detect)
(format t "*rms is singing Free Hackers nearby*~%"))
(loop named make-move
do (loop for x from 0 for exit in exits do
(format t "~d to exit to ~a~%" x (cdr exit))
finally
(progn (format t "Your choice or FREE [number]~%"
(format t "to attempt to be free~%~%: "))))
do (handler-case
(let ((line (read-line)))
(cond ((string= line "quit") (quit))
((> (length line) 5)
(let ((end (traverse
(car (nth (parse-integer (subseq line 5))
exits))
maze)))
(format t "~a~%"
(if (member 'wumpus (cadr end))
"You achieved freedom in this life"
"hoarders gocha :-(" #|)|# ))
(mapc (lambda (x) (print (cadr X)))
(flatten maze 2)) (terpri)
(quit)))
(t (let* ((select (parse-integer line))
(new-maze (traverse
(car (nth (parse-integer line)
exits))
maze)))
(if (member 'wumpus (cadr new-maze))
(progn (print "you spooked the wumpus") (terpri) (quit))
(progn (setf maze new-maze)
(return-from make-move)))))))
(t (c) (format t "You weren't meant to ~a~%" c)))))))
(defun play ()
(let ((maze (encircle 5)))
(place-wumpus maze)
(hunt maze)))