;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                         Problem 3 Solution                        ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod (dequeue (q <queue>))
  (let ((obj (queue-top q)))
    (set! (elements q) (tail (elements q)))
    obj))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                         Problem 4 Solution                        ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass <mortal> (<character>)
  (lifespan :type <integer> :initarg :lifespan :accessor lifespan))

(defclass <duck> (<mortal>)
  (nickname    :initvalue 'duck)
  (name        :initvalue "A Duck")
  (description :initvalue
               '("This duck is pretty heavy - it almost weighs as much"
                 "as a witch. Perhaps it is carrying something."))
  (lifespan    :initvalue 90)
  (plan        :initvalue
               (lambda (d)
                 (unless (eq? (location d) *null-place*)
                   (when (zero? (random 2))
                     (make <duck>
                           :location (location d))
                     (make <duck>
                           :location (location d)))
                   (kill d))
                 #f)))

(defmethod (start-time (d <duck>))
  (lifespan d))

(define chr:duck
  (make <duck> :location loc:gallows))

(defmethod (fight (a <player>) (d <duck>))
  (tell a "Ducks are easy to fight, so you use your bare hands")
  (let ((r (random 10)))
    (cond ((< r 5)
           (tell a "But, this duck is giving you your money's worth.")
           (tell a "So you just decide to give up..."))
          ((< r 8)
           (tell a "Wow, you really know how to catch your dinner")
           (kill d)
           (tell a "Well, looky there, this duck was carrying a")
           (tell a "Holy Hand Grenade, what a great prize")
           (make <weapon>
                 :nick 'grenade
                 :name "The Holy Hand Grenade of Antioch"
	         :location (location a) :potency 40
                 :description
                 '("The most dreaded of the Holy Weapons, the Holy Hand"
                   "Grenade was a favourite of Saint Attila.")))
          (else
           (tell a "What terrible luck you have... You can't even win")
           (tell a "a fight with a duck, how do you expect to find the")
           (tell a "Holy Grail...")
           (kill a)))
    #t))

(defmethod (message (d <duck>) (from <player>)
                    (type = 'enter) (msg <string>))
  (let ((l (location d)))
    (emote d "runs away.... Quack, Quack...")
    (transfer d l (random-elt (exits l)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                         Problem 5 Solution                        ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass <wheelbarrow> (<container> <inanimate>))

;;; Modify the look descriptions for wheelbarrows
(defmethod (description (w <wheelbarrow>))
  (let ((stuff (map name+nick (contents w))))
    (append (call-next-method)
            (list "This wheelbarrow contains:")
            (if (null? stuff)
                (list "  Nothing, nada, zilch, zip... It's empty")
                (map (lambda (x) (add "  " x)) stuff)))))

(add-player-command
 (list 'put symbol? 'in symbol?)
 "put <something> in <wheelbarrow>"  ;;; Help description
 (lambda (plyr inp)
   (let* ((cart (nick-find (last inp) (contents plyr)))
          (objects (append (filter (lambda (x)
                                     (and (inanimate? x)
                                          (not (instance-of?
                                                  x <fighter>))))
                                   (contents (location plyr)))
                           (filter inanimate? (contents plyr))))
          (object (nick-find (second inp) objects)))
     (cond
      ((not cart)
       (echos "Couldn't find" (last inp) "in your possesions"))
      ((not (instance-of? cart <wheelbarrow>))
       "That's not a wheelbarrow")
      ((eq? cart object)
       "This meta-circular wheelbarrow thing is confusing...")
      (object
       (insert-immediate-event
        (lambda () (transfer object (location object) cart)))
       #t)
      ((null? objects) "There's nothing to put in the wheelbarrow")
      (else
       (echos "You look around, but you can't find" (second inp)))))))

(add-player-command
 (list 'get symbol? 'from symbol?)
 "get <something> from <wheelbarrow>"   ;;; Help description
 (lambda (plyr inp)
   (let ((cart (nick-find (last inp) (contents plyr))))
     (cond
      ((not cart)
       (echos "Couldn't find" (last inp) "in your possessions"))
      ((not (instance-of? cart <wheelbarrow>))
       "That's not a wheelbarrow")
      ((nick-find (second inp) (contents cart))
       (let ((object (nick-find (second inp) (contents cart))))
         (insert-immediate-event
          (lambda () (transfer object cart plyr)))
         #t))
      ((null? (contents cart)) "The wheelbarrow is empty")
      (else
       (echos "You look in" (name cart)
              "but can't find" (second inp)))))))

(add-player-command
 (list 'dump symbol? symbol?)
 "dump <wheelbarrow> <place>    Empties cart in adjacent place"
 (lambda (plyr inp)
   (let* ((cart (nick-find (second inp) (contents plyr)))
          (place (nick-find (last inp) (exits (location plyr)))))
     (cond
      ((not cart)
       (echos "Couldn't find" (second inp) "in your possessions"))
      ((not place)
       (echos "You look around but can't find" (last inp)))
      ((not (instance-of? cart <wheelbarrow>))
       "That's not a wheelbarrow")
      (else
       (for-each (lambda (o)
                   (transfer o cart place))
                 (contents cart))
       #t)))))

(define obj:wheelbarrow
  (make <wheelbarrow> :nick 'cart :name "Wheelbarrow of Death"
        :location loc:gallows
        :description
        '("It's a rickety old thing. One wheel is coming loose."
          "This here wheelbarrow sure seems like she's seen her days.")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                         Problem 6 Solution                        ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric (find-path start target))

(defmethod (find-path (start <place>) (target <contained>))
  (find-path start (location target)))

(defmethod (find-path (start <place>) (target <place>))
  ;;; Combine lists of places for the history
  (define (history-union frontier been-there)
    (cond ((null? frontier)
           been-there)
          ((memq (head frontier) been-there)
           (history-union (tail frontier) been-there))
          (else
           (history-union (tail frontier)
                          (cons (head frontier) been-there)))))
  ;;; Expand the frontier of searches by building the associative
  ;;; lists of the form (step-n ... step-2 step1)
  (define expand
    ;;; add-exits creates new lists for all the paths starting
    ;;; with path and heading towards the escapes
    (letrec ((add-exits
              (lambda (past path more-paths escapes)
                (cond ((null? escapes) more-paths)
                      ((memq (head escapes) past)
                       (add-exits past
                                  path
                                  more-paths
                                  (tail escapes)))
                      (else
                       (add-exits past
                                  path
                                  (cons (cons (head escapes) path)
                                        more-paths)
                                  (tail escapes)))))))
      ;;; Creates the longer paths for each of the current paths
      (lambda (history paths new-paths)
        (if (null? paths)
          new-paths
          (expand history
                  (tail paths)
                  (add-exits history
                             (head paths)
                             new-paths
                             (exits (head (head paths)))))))))
  ;;; Main algorithm - searches the associative list of paths
  ;;; If destination is found, then returns the next step.
  ;;; If all paths are exhausted, returns #f.
  (define (travel history paths)
    (let ((found (assq target paths)))
      (cond
       (found (last found))
       ((null? paths) #f)
       (else
        (travel (history-union (map head paths)
                               history)
                (expand history paths empty))))))
  (if (eq? start target)
    target
    (travel (list start) (map list (exits start)))))

(define chr:reaper
  (make <character> :nick 'reaper :name "The Grim Reaper"
        :location loc:earth
        :description 
        '("He's one bad dude, but he keeps the place clean. Don't"
          "you wish there were grim reapers nowadays.")
        :plan
        (letrec         ;;; Make the search for corpses locally defined
            ((corpse? (lambda (c) (instance-of? c <corpse>)))
             ;;; If a character in chars has a corpse, returns that
             ;;; character, otherwise returns #f
             (check-chars
              (lambda (chars)
                (cond ((null? chars) #f)
                      ((null? (filter corpse? (contents (head chars))))
                       (check-chars (tail chars)))
                      (else (head chars)))))
             ;;; If any place in places has a corpse, returns #t
             (check-places
              (lambda (places)
                (let ((objects (if (null? places)
                                 empty
                                 (contents (head places)))))
                  (cond ((null? places) #f)
                        ((not (null? (filter corpse? objects)))
                         (head places))
                        ((check-chars (filter animate? objects))
                         (head places))
                        (else
                         (check-places (tail places)))))))
             ;;; Build list of new places to search for corpses
             (build-unknowns
              (lambda (history frontier unknown)
                (if (null? frontier)
                  unknown
                  (build-unknowns history
                                  (tail frontier)
                                  (append (filter
                                           (lambda (x)
                                             (not (memq x history)))
                                           (exits (head frontier)))
                                          unknown)))))
             ;;; Searches unknown for corpses, if no corpses in unknown
             ;;; then search the exits of unknown (without repetition).
             ;;; Returns #f if the unknown list is exhausted. If a
             ;;; place with a corpse is found, returns that place.
             (find-corpse
              (lambda (checked unknown)
                (let ((found (check-places unknown)))
                  (cond ((null? unknown) #f)
                        (found found)
                        (else
                         (let ((new-checked (append unknown checked)))
                           (find-corpse new-checked
                                        (build-unknowns new-checked
                                                        unknown
                                                        empty)))))))))
            (lambda (r)
              (let* ((cart obj:wheelbarrow)
                     (lreap (location r))
                     (lcart (location cart))
                     (things (contents lreap))
                     (corpses (filter corpse? things))
                     (dirt-bag (check-chars (filter animate? things))))
              (if (eq? lcart r) ;;; Does the reaper have the wheelbarrow
                (cond ((not (null? corpses))  ;;; Pickup some corpses
                       (for-each (lambda (c) (transfer c lreap cart))
                                 corpses)
                       0)
                      (dirt-bag             ;;; Kill someone with corpse
                       (kill dirt-bag)
                       3)
                      ((and (not (empty? (contents cart)))  ;;; Dump
                            (memq loc:peril (exits lreap))) ;;; Corpses
                       (for-each (lambda (o) (transfer o
                                                       cart
                                                       loc:peril))
                                 (contents cart))
                       0)
                      (else
                       (let ((next-corpse   ;;; Locate a corpse to get
                              (find-corpse
                               (list lreap loc:microsoft loc:peril)
                               (filter (lambda (x)
                                         (not (or (eq? x loc:microsoft)
                                                  (eq? x loc:peril))))
                                       (exits lreap)))))
                         (cond
                          (next-corpse  ;;; Go get the corpse, if there
                           (transfer r
                                     lreap
                                     (find-path lreap next-corpse))
                           (say r "Bring out your dead!")
                           5)
                          ((eq? lreap loc:pub)  ;;; Otherwise get drunk
                           (say r
                                (random-elt
                                 '("Henry the Eigth, I am, I am..."
                                   "Wow, I need a drink"
                                   "You know anything about ducks?"
                                   "I here you have a toilet around here"
                                   "I'm dying here... Ha ha ha ha...")))
                           10)
                          (else   ;;; Head towards the pub to get drunk
                           (transfer r lreap (find-path lreap loc:pub))
                           (say r "Bring out your dead!")
                           5)))))
                (cond ((eq? lcart lreap)  ;;; Found the wheelbarrow
                       (transfer obj:wheelbarrow lcart r)
                       2)
                      ((and (animate? lcart)  ;;; Kill wheelbarrow thief
                            (eq? lreap (location lcart)))
                       (kill lcart)
                       3)
                      (else               ;;; Head for the wheelbarrow
                       (transfer r lreap (find-path lreap lcart))
                       4))))))))
          
(defmethod (message (r = chr:reaper) (from <player>)
                    (type = 'enter) (msg <string>))
  (say r "Bring out your dead!"))

(defmethod (fight (a <player>) (r = chr:reaper))
  (tell a "While fighting death is a noble pursuit, ultimately")
  (tell a "it's a futile pursuit....")
  (kill a)
  #t)