DataMuseum.dk

top - download

    Length: 5134 (0x140e)
    Types: TextFile
    Names: »adventure.scm«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/psets/adventure.scm« 

TextFile

;;
;; This is the file adventure.scm
;;

;;
;; Here we define places, people, things, as well as 
;; generally useful procedures. You won't have to modify 
;; any of these procedures, so just load this file into Scheme.
;;

(define (make-place name)
  (let ((neighbors '()) (things '()))
    (lambda (m)
      (cond ((eq? m 'name) name)
	    ((eq? m 'things) things)
	    ((eq? m 'neighbors)
	     (mapcar cdr neighbors))
	    ((eq? m 'exits)
	     (mapcar car neighbors))
	    ((eq? m 'type) 'place)
	    ((eq? m 'look-in)
	     (lambda (direction)
	       (let ((p (assq direction neighbors)))
		 (if p (cdr p) nil))))
	    ((eq? m 'appear)
	     (lambda (new-thing)
	       (if (memq new-thing things)
		   (error "Thing already in this place"
			  (list name new-thing)))
	       (set! things (cons new-thing things))))
	    ((eq? m 'gone)
	     (lambda (thing)
	       (if (not (memq thing things))
		   (error "Disappearing thing not here"
			  (list name thing)))
	       (set! things (delete thing things))))
	    ((eq? m 'new-neighbor)
	     (lambda (direction new-neighbor)
	       (if (assq direction neighbors)
		   (error "Direction already assigned a neighbor"
			  (list name direction)))
	       (set! neighbors
		     (cons (cons direction new-neighbor)
			   neighbors))))
	    (else
	     (error "I don't know how to do this -- place"
		    (list name m)))))))

;;
;; Here is how we define people.
;;

(define (make-person name place threshold)
  (let ((possessions '())
	(restlessness 0))
    
    (define (me m)
      (cond ((eq? m 'type) 'person)
	    ((eq? m 'name) name)
	    ((eq? m 'place) place)
	    ((eq? m 'look-around)
	     (forall (place 'things)
		     (lambda (thing)
		       (if (not (eq? me thing))
			   (print (thing 'name))))))
	    ((eq? m 'take)
	     (lambda (thing)
	       (if (memq thing (place 'things))
		   (sequence
		    (newline)
		    (princ name)
		    (princ " took ")
		    (princ (thing 'name))
		    (set! possessions (cons thing possessions))
		    (forall (filter (place 'things) 'person)
			    (lambda(p)
				(if (and (not (eq? p me))
					 (memq thing (p 'possessions)))
				    (sequence
				     ((p 'lose) thing)
				     (have-fit p))))))
		   (error "Thing taken not at this place"
			  (list (place 'name) thing)))))
	    ((eq? m 'lose)
	     (lambda (thing)
	       (set! possessions (delete thing possessions))))
	    ((eq? m 'list-possessions)
	     (forall possessions
		     (lambda (thing)
		       (newline)
		       (princ (thing 'name))
		       (princ " "))))
	    ((eq? m 'current-position)
	     (newline)
	     (princ (place 'name)))
	    ((eq? m 'exits)
	     (place 'exits))
	    ((eq? m 'go)
	     (lambda (direction)
	       (let ((new-place ((place 'look-in)
				 direction)))
		 (if new-place
		     (move-to new-place)
		     (sequence
		      (newline)
		      (princ "Can't go ")
		      (princ direction)
		      (princ " from ")
		      (princ (place 'name)))))))
	    ((eq? m 'possessions) possessions)
	    ((eq? m 'move)
	     (set! restlessness (1+ restlessness))
	     (if (> restlessness threshold)
		 (let ((new-place (random-place place)))
		   (if new-place (move-to new-place)))))
	    ((eq? m 'go-to-heaven)
	     (forall possessions
		     (lambda(p)
		       ((me 'lose) p)))
	     ((place 'gone) me)
	     ((heaven 'appear) me)
	     (set! place heaven))
	    (else
	     (error "I don't know how to do this -- person"
		    (list name m)))))


    (define (move-to new-place)
      (newline)
      (princ name)
      (princ " moved from ")
      (princ (place 'name))
      (princ " to ")
      (princ (new-place 'name))
      (set! restlessness 0)
      (forall possessions
	      (lambda (p)
		((place 'gone) p)
		((new-place 'appear) p)))
      (let ((new-place-people
	     (filter (new-place 'things) 'person)))
	(if new-place-people
	    (sequence
	     (newline)
	     (princ name)
	     (princ " says - Hi, ")
	     (forall new-place-people
		     (lambda(p)
		       (princ (p 'name))
		       (princ " "))))))
      ((place 'gone) me)
      ((new-place 'appear) me)
      (set! place new-place)
      nil)

    ((place 'appear) me)
    (enqueue me)
    me))

(define (have-fit p)
  (newline)
  (princ "Yaaaah! ")
  (princ (p 'name))
  (princ " is upset!"))

(define (random-place old-place)
  (let ((places (old-place 'neighbors)))
    (if places
	(nth (random (length places)) places)
	nil)))

;;
;; A very simple implementation of things
;;

(define (make-thing name)
  (lambda (m)
    (cond ((eq? m 'type) 'thing)
	  ((eq? m 'name) name)
	  (else
	   (error "I don't know how to do this -- thing"
		  (list name m))))))

;;
;; Procedures that are generally useful
;;

(define (forall set f)
  (cond ((null? set) nil)
	(else (f (car set))
	      (forall (cdr set) f))))

(define (filter set type)
  (cond ((null? set) nil)
	((eq? ((car set) 'type) type)
	 (cons (car set) (filter (cdr set) type)))
	(else (filter (cdr set) type))))

(define (delete o possessions)
  (let ((answer nil))
    (forall possessions
	    (lambda (elem)
	      (if (not (eq? elem o))
		  (set! answer (cons elem answer)))))
    answer))