DataMuseum.dk

top - metrics - download

    Length: 4927 (0x133f)
    Types: TextFile
    Names: »ps6.scm«

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

TextFile

;;
;; This is the file ps6.scm
;;

;;
;; This file defines our imaginary world
;;

;; Here we initialize the queue of people in our world and define several
;; useful related procedures.

(define queue '())

(define (enqueue person)
  (set! queue (cons person queue)))

(define (unqueue person)
  (set! queue (delete person queue)))


;; Here we define the places in our world

(define Bldg-36 (make-place 'Bldg-36))
(define wms-office (make-place 'wms-office))
(define hal-office (make-place 'hal-office))
(define computer-lab (make-place 'computer-lab))
(define EGG-Atrium (make-place 'EGG-Atrium))
(define Bldg-10 (make-place 'Bldg-10))
(define dormitory (make-place 'dormitory))
(define heaven (make-place 'heaven))
(define dungeon (make-place 'dungeon))
(define dean-office (make-place 'dean-office))

;; The world is connected together by an accessibility function.
;; The accessibility function is constructed from (one-way!) paths
;; connecting individual places.

(define (can-go from direction to)
  ((from 'new-neighbor) direction to))

(can-go Bldg-36 'up computer-lab)
(can-go Bldg-36 'north hal-office)
(can-go Bldg-36 'west EGG-Atrium)
(can-go hal-office 'south Bldg-36)
(can-go computer-lab 'down Bldg-36)
(can-go wms-office 'down computer-lab)
(can-go dormitory 'east Bldg-10)
(can-go Bldg-10 'west dormitory)
(can-go EGG-Atrium 'up wms-office)
(can-go dungeon 'up EGG-Atrium)
(can-go Bldg-10 'north EGG-Atrium)
(can-go EGG-Atrium 'south Bldg-10)
(can-go dean-office 'west dormitory)
(can-go dean-office 'down Bldg-10)
(can-go EGG-Atrium 'east Bldg-36)

;; We define persons as follows:

(define wms (make-person 'wms wms-office 1))
(define hal (make-person 'hal hal-office 2))

;;
;;Here we define a TROLL and a DEAN
;;

(define (make-troll place threshold)
  (let ((hunger 0) (possessions '()))
    (define (me m)
      (cond ((eq? m 'type) 'person)
	    ((eq? m 'name) 'troll)
	    ((eq? m 'place) place)
	    ((eq? m 'possessions) possessions)
	    ((eq? m 'current-position)
	     (newline)
	     (princ (place 'name)))
	    ((eq? m 'move)
	     (set! hunger (1+ hunger))
	     (if (> hunger threshold)
		 (if (other-persons-at-place place)
		     (eat-person (other-persons-at-place place))
		     (let ((new-place (random-place place)))
		       (if new-place (move-to new-place))))))
	    (else
	     (error "I don't know how to do this -- troll" m))))

    (define (other-persons-at-place place)
      (delete me
	      (filter (place 'things) 'person)))

    (define (eat-person persons)
      (let ((selected-person
	     (nth (random (length persons)) persons)))

	             nil

	))

    (define (move-to new-place)
      (newline)
      (princ "TROLL moved from ")
      (princ (place 'name))
      (princ " to ")
      (princ (new-place 'name))
      ((place 'gone) me)
      ((new-place 'appear) me)
      (set! place new-place)
      (if (other-persons-at-place new-place)
	  (eat-person (other-persons-at-place new-place))))
    
    ((place 'appear) me)
    me))



(define (make-dean place threshold)
  (let ((officiousness 0)
	(possessions '()))
    (define (me m)
      (cond ((eq? m 'type) 'person)
	    ((eq? m 'go-to-heaven)
	     ((place 'gone) me)
	     ((heaven 'appear) me)
	     (set! place heaven))
	    ((eq? m 'name) 'dean)
	    ((eq? m 'place) place)
	    ((eq? m 'possessions) possessions)
	    ((eq? m 'current-position)
	     (newline)
	     (princ (place 'name)))
	    ((eq? m 'move)
	     (set! officiousness
		   (1+ officiousness))
	     (if (> officiousness threshold)
		 (if (who-has-beer place)
		     (smash-beer place)
		     (let ((new-place (random-place place)))
		       (if new-place (move-to new-place))))))
	    (else
	     (error "I don't know how to do this -- dean" m))))

    (define (who-has-beer place)

	       nil

      )

    (define (smash-beer this-place)
      (newline)
      (princ "DEAN says - Ah-HAH! Caught you!!")
      (newline)
      (princ "I do not approve of beer on campus!")
      (newline)
      (princ "DEAN smashes beer and returns")
      (newline)
      (princ "to DEAN-OFFICE")
      (forall
       (who-has-beer this-place)
       (lambda(p)
	      ((p 'lose) beer)
	      (have-fit p)
	      ((this-place 'gone) beer)))
      (set! officiousness 0)
      ((this-place 'gone) me)
      ((dean-office 'appear) me)
      (set! place dean-office)
      nil)

    (define (move-to new-place)
      (newline)
      (princ "DEAN moved from ")
      (princ (place 'name))
      (princ " to ")
      (princ (new-place 'name))
      ((place 'gone) me)
      ((new-place 'appear) me)
      (set! place new-place)
      (if (who-has-beer place)
	  (smash-beer place)))

    ((place 'appear) me)
    me))

(define troll (make-troll dungeon 3))
(define dean (make-dean dean-office 3))

;;
;;Finally, we define the clock that will control our world:
;;

(define (clock)
   (forall queue move))

(define (move person)
  (person 'move))