;; This file contains excerpts from the textbook Concrete
;; Abstractions: An Introduction to Computer Science Using Scheme, by
;; Max Hailperin, Barbara Kaiser, and Karl Knight, Copyright (c) 1998
;; by Brooks/Cole Publishing Company. This file may not be reproduced
;; or redistributed other than for use with that textbook.

;; Chapter 14: Object-Oriented Programming

;; 14.5  An Application: Adventures in the Imaginary Land of Gack

object
   registry
   named-object
      thing
         scroll
      place
      person
         auto-person
            wizard
            witch
   class

(define-class
  'registry
  object-class
  '(list)
  '(add
    remove
    trigger
    trigger-times))

(class/set-method!
 registry-class 'init
 (lambda (this)
   (object^init this)
   (registry/set-list! this '())))

(class/set-method!
 registry-class 'add
 (lambda (this person)
   (registry/set-list! this
                       (cons person
                             (registry/get-list this)))))

(class/set-method!
 registry-class 'remove
 (lambda (this person)
   (registry/set-list! this
                       (delq person
                             (registry/get-list this)))))

(class/set-method!
 registry-class 'trigger
 (lambda (this)
   (for-each auto-person/maybe-act
             (registry/get-list this))))

(class/set-method!
 registry-class 'trigger-times
 (lambda (this n)
   (if (> n 0)
       (begin (registry/trigger this)
              (registry/trigger-times this (- n 1)))
       'done)))

(define delq
  (lambda (item list)
    (filter (lambda (x)
              (not (eq? x item)))
            list)))

(define-class
  'named-object
  object-class
  '(name)
  '(name
    change-name))

(class/set-method!
 named-object-class 'init
 (lambda (this name)
   (object^init this)
   (named-object/set-name! this name)))

(class/set-method!
 named-object-class 'name
 (lambda (this)
   (named-object/get-name this)))

(class/set-method!
 named-object-class 'change-name
 (lambda (this new-name)
   (named-object/set-name! this new-name)))

(define-class
  'thing
  named-object-class
  '(owner)
  '(owned?
    owner
    become-unowned
    become-owned-by))

(class/set-method!
 thing-class 'init
 (lambda (this name)
   (named-object^init this name)
   (thing/set-owner! this 'no-one)))

(class/set-method!
 thing-class 'owned?
 (lambda (this)
   (not (equal? (thing/owner this)
                'no-one))))

(class/set-method!
 thing-class 'owner
 (lambda (this)
   (thing/get-owner this)))

(class/set-method!
 thing-class 'become-unowned
 (lambda (this)
   (thing/set-owner! this 'no-one)))

(class/set-method!
 thing-class 'become-owned-by
 (lambda (this person)
   (thing/set-owner! this person)))

(define-class
  'scroll
  thing-class
  '()
  '(be-read))

(class/set-method!
 scroll-class 'init
 (lambda (this title)
   (thing^init this title)))

(class/set-method!
 scroll-class 'be-read
 (lambda (this)
   (let ((owner (scroll/owner this))
         (title (scroll/name this)))
     (if (scroll/owned? this)
         (person/say owner
                     (list "I have read" title))
         (display-message (list "No one has" title))))))

(define display-message
  (lambda (list-of-stuff)
    (newline)
    (for-each (lambda (s) (display s) (display " "))
              list-of-stuff)))

(define-class
  'place
  named-object-class
  '(neighbor-map ; pairs: car = direction, cdr = neighbor
    contents)    ; people and things
  '(exits
    neighbors
    neighbor-towards
    add-new-neighbor
    gain
    lose
    contents))

(class/set-method!
 place-class 'init
 (lambda (this name)
   (named-object^init this name)
   (place/set-neighbor-map! this '())
   (place/set-contents! this '())))

(class/set-method!
 place-class 'exits
 (lambda (this)
   (map car (place/get-neighbor-map this))))

(class/set-method!
 place-class 'neighbors
 (lambda (this)
   (map cdr (place/get-neighbor-map this))))

(class/set-method!
 place-class 'neighbor-towards
 (lambda (this direction)
   (let ((p (assq direction
                  (place/get-neighbor-map this))))
      (if (not p)
          #f
          (cdr p)))))

(class/set-method!
 place-class 'add-new-neighbor
 (lambda (this direction new-neighbor)
   (let ((neighbor-map (place/get-neighbor-map this)))
     (if (assq direction neighbor-map)
         (display-message
          (list "there is already a neighbor"
                direction
                "from"
                (place/name this)))
         (place/set-neighbor-map! this
                                  (cons (cons direction 
                                              new-neighbor)
                                        neighbor-map))))))

(class/set-method!
 place-class 'gain
 (lambda (this new-item)
   (let ((contents (place/contents this)))
     (if (memq new-item contents)
         (display-message 
          (list (named-object/name new-item)
                "is already at"
                (place/name this)))
         (place/set-contents! this
                              (cons new-item contents))))))

(class/set-method!
 place-class 'lose
 (lambda (this item)
   (let ((contents (place/contents this)))
     (if (not (memq item contents))
         (display-message 
          (list (named-object/name item)
                "is not at"
                (place/name this)))
         (place/set-contents! this
                              (delq item contents))))))

(class/set-method!
 place-class 'contents
 (lambda (this)
   (place/get-contents this)))

(define-class
  'person 
  named-object-class
  '(place
    possessions)
  '(say
    look-around
    list-possessions
    read
    have-fit
    move-to
    go
    take
    lose
    place
    possessions
    greet
    other-people-at-same-place))

(class/set-method!
 person-class 'init
 (lambda (this name place)
   (named-object^init this name)
   (person/set-place! this place)
   (person/set-possessions! this '())
   (place/gain place this)))

(class/set-method!
 person-class 'say
 (lambda (this list-of-stuff)
   (let ((name (person/name this))
         (place (person/place this)))
     (let ((place-name (place/name place)))
       (display-message
        (append (list "At" place-name ":" name "says --")
                list-of-stuff))))))

(class/set-method!
 person-class 'look-around
 (lambda (this)
   (let ((place (person/place this)))
     (let ((other-items
            (map named-object/name
                 (delq this
                       (place/contents place))))
           (exits (place/exits place)))
       (person/say this
                   (append '("I see")
                           (verbalize-list other-items "nothing")
                           '("and can go")
                           (verbalize-list exits "nowhere")))))))
               
(class/set-method!
 person-class 'list-possessions
 (lambda (this)
   (let ((stuff (map thing/name
                     (person/possessions this))))
     (person/say
      this
      (append '("I have")
              (verbalize-list stuff "nothing"))))))

(class/set-method!
 person-class 'read
 (lambda (this scroll)
   (if (eq? this (scroll/owner scroll))
       (scroll/be-read scroll)
       (display-message
        (list (person/name this)
              "does not have"
              (scroll/name scroll))))))

(class/set-method!
 person-class 'have-fit
 (lambda (this)
   (person/say this '("Yaaaah! I am upset!"))))

(class/set-method!
 person-class 'move-to
 (lambda (this new-place)
   (let ((name (person/name this))
         (old-place (person/place this))
         (possessions (person/possessions this)))
     (display-message
      (list name "moves from" (place/name old-place)
            "to" (place/name new-place)))
     (place/lose old-place this)
     (place/gain new-place this)
     (for-each (lambda (p)
                 (place/lose old-place p)
                 (place/gain new-place p))
               possessions)
     (person/set-place! this new-place)
     (person/greet this
                   (person/other-people-at-same-place this)))))

(class/set-method!
 person-class 'go
 (lambda (this direction)
   (let ((old-place (person/place this)))
     (let ((new-place (place/neighbor-towards
                       old-place
                       direction)))
       (if new-place
           (person/move-to this new-place)
           (display-message
            (list "you cannot go" direction "from"
                  (place/name old-place))))))))

(class/set-method!
 person-class 'take
 (lambda (this thing)
   (if (eq? this (thing/owner thing))
       (display-message
        (list (person/name this) "already has" (thing/name thing)))
       (begin
         (if (thing/owned? thing)
             (let ((owner (thing/owner thing)))
               (person/lose owner thing)
               (person/have-fit owner))
             'unowned)
         (thing/become-owned-by thing this)
         (person/set-possessions!
          this
          (cons thing (person/possessions this)))
         (person/say
          this
          (list "I take" (thing/name thing)))))))

(class/set-method!
 person-class 'lose
 (lambda (this thing)
   (if (not (eq? this (thing/owner thing)))
       (display-message (list (person/name this) "doesn't have"
                              (thing/name thing)))
       (begin
         (thing/become-unowned thing)
         (person/set-possessions!
          this
          (delq thing (person/possessions this)))
         (person/say
          this
          (list "I lose" (thing/name thing)))))))

(class/set-method!
 person-class 'place
 (lambda (this)
   (person/get-place this)))

(class/set-method!
 person-class 'possessions
 (lambda (this)
   (person/get-possessions this)))

(class/set-method!
 person-class 'greet
 (lambda (this people)
   (if (not (null? people))
       (person/say this
                   (cons "Hi"
                         (verbalize-list
                          (map person/name people)
                          "no one")))
       'no-one-to-greet)))

(class/set-method!
 person-class 'other-people-at-same-place
 (lambda (this)
   (delq this
         (filter person?
                 (place/contents (person/place this))))))

(define verbalize-list
  (lambda (items none-word)
    (define loop
      (lambda (items)
        (if (null? (cdr items))
            items
            (cons (car items)
                  (cons "and"
                        (loop (cdr items)))))))
    (if (null? items)
        (list none-word)
        (loop items))))

(define-class
  'auto-person
  person-class
  '(threshold
    restlessness)
  '(maybe-act
    act))

(class/set-method!
 auto-person-class 'init
 (lambda (this name place threshold)
   (person^init this name place)
   (auto-person/set-threshold! this threshold)
   (auto-person/set-restlessness! this 0)
   (registry/add registry this)))

(class/set-method!
 auto-person-class 'maybe-act
 (lambda (this)
   (let ((threshold (auto-person/get-threshold this))
         (restlessness (auto-person/get-restlessness this)))
      (if (< restlessness threshold)
          (auto-person/set-restlessness! this
                                         (+ 1 restlessness))
          (begin (auto-person/act this)
                 (auto-person/set-restlessness! this 0))))))

(class/set-method!
 auto-person-class 'act
 (lambda (this)
   (let ((new-place (random-element
                     (place/neighbors
                      (auto-person/place this)))))
     (if new-place
         (auto-person/move-to this new-place)))))

(define random-element
  (lambda (list)
    (if (null? list)
        #f
        (list-ref list (random (length list))))))

(define-class
  'witch
  auto-person-class
  '()
  '(curse))
(class/set-method!
 witch-class 'act
 (lambda (this)
   (let ((victim (random-element
                  (witch/other-people-at-same-place this))))
     (if victim
         (witch/curse this victim)
         (auto-person^act this)))))

(class/set-method!
 witch-class 'curse
 (lambda (this person)
   (let ((person-name (person/name person)))
     (person/say this
                 (list
                  "Hah hah hah, I'm going to turn you into a frog"
                  person-name))
     (turn-into-frog person)
     (person/say this
                 (list "Hee hee" person-name
                       "looks better in green!")))))

(define turn-into-frog
  (lambda (person)
    (for-each (lambda (item) (person/lose person item))
              (person/possessions person))
    (person/say person '("Ribbitt!"))
    (person/move-to person pond)
    (registry/remove registry person)))

(define-class
  'wizard
  auto-person-class
  '()
  '())

(class/set-method!
 wizard-class 'act
 (lambda (this)
   (let ((place (wizard/place this)))
     (let ((scrolls (filter scroll?
                            (place/contents place))))
       (if (and (not (null? scrolls))
                (not (eq? place chamber-of-wizards)))
           (begin
             (wizard/take this (car scrolls))
             (wizard/move-to this chamber-of-wizards)
             (wizard/lose this (car scrolls)))
           (auto-person^act this))))))

;; The "registry" is an object that keeps track of all
;; the auto-person objects that need to be given an
;; opportunity to act.

(define registry (make-registry))

;; Here we define the places in the imaginary world of Gack

(define food-service (make-place 'food-service))
(define PO (make-place 'PO))
(define alumni-hall (make-place 'alumni-hall))
(define chamber-of-wizards (make-place 'chamber-of-wizards))
(define library (make-place 'library))
(define good-ship-olin (make-place 'good-ship-olin))
(define lounge (make-place 'lounge))
(define computer-lab (make-place 'computer-lab))
(define offices (make-place 'offices))
(define dormitory (make-place 'dormitory))
(define pond (make-place 'pond))

;; One-way paths connect individual places in the world.

(place/add-new-neighbor food-service 'down PO)
(place/add-new-neighbor PO 'south alumni-hall)
(place/add-new-neighbor alumni-hall 'north food-service)
(place/add-new-neighbor alumni-hall 'east chamber-of-wizards)
(place/add-new-neighbor alumni-hall 'west library)
(place/add-new-neighbor chamber-of-wizards 'west alumni-hall)
(place/add-new-neighbor chamber-of-wizards 'south dormitory)
(place/add-new-neighbor dormitory 'north chamber-of-wizards)
(place/add-new-neighbor dormitory 'west good-ship-olin)
(place/add-new-neighbor library 'east alumni-hall)
(place/add-new-neighbor library 'south good-ship-olin)
(place/add-new-neighbor good-ship-olin 'north library)
(place/add-new-neighbor good-ship-olin 'east dormitory)
(place/add-new-neighbor good-ship-olin 'up lounge)
(place/add-new-neighbor lounge 'west computer-lab)
(place/add-new-neighbor lounge 'south offices)
(place/add-new-neighbor computer-lab 'east lounge)
(place/add-new-neighbor offices 'north lounge)

;; We define persons as follows:

;; We've chosen to define max-the-person rather than
;; redefining max, which is predefined in Scheme to
;; be a procedure for finding the largest of its numeric
;; arguments.
(define max-the-person
  (make-auto-person 'max offices 2))

(define karl
  (make-auto-person 'karl computer-lab 4))

(define barbara
  (make-witch 'barbara offices 3))

(define elvee
  (make-wizard 'elvee chamber-of-wizards 1))

(define player
  (make-person 'player dormitory))

;; and now we'll strew some scrolls around:

(define scroll-of-enlightenment
  (make-scroll 'scroll-of-enlightenment))
(place/gain library scroll-of-enlightenment)

(for-each (lambda (title)
            (place/gain library
                        (make-scroll title)))
          '(crime-and-punishment war-and-peace
                                 iliad
                                 collected-works-of-rilke))

(define unix-programmers-manual
  (make-scroll 'unix-programmers-manual))
(place/gain computer-lab unix-programmers-manual)

(define next-users-reference
  (make-scroll 'next-users-reference))
(place/gain computer-lab next-users-reference)

(define difficulty 1)

(define play
  (lambda ()
    (define loop
      (lambda ()
        (newline)
        (let ((user-input (read)))
          (if (equal? user-input '(quit))
              'done
              (begin
                (respond-to-using user-input gack-p/a-list)
                (loop))))))
    (newline)
    (display "Enter your name, using one word only, please.")
    (newline)
    (person/change-name player (read))
    (display-message
     (list "OK," (person/name player)
           "enter your commands one by one"
           "as scheme lists; to get help enter (help)."))
    (loop)))

(define gack-p/a-list
  (list (make-pattern/action '(help)
                             (lambda ()
                               (newline)
                               (display "Possibilities:")
                               (newline)
                               (for-each (lambda (command)
                                           (display " ")
                                           (display command)
                                           (newline))
                                         '((help)
                                           (quit)
                                           (drop thing)
                                           (lose thing)
                                           (take thing)
                                           (go direction)
                                           (read scroll)
                                           (inventory)
                                           (list possessions)
                                           (look)
                                           (look around)
                                           (say ...)))
                               (newline)))
        (make-pattern/action (list '(drop lose) thing?)
                             (lambda (verb thing)
                               (person/lose player thing)
                               (registry/trigger-times
                                registry difficulty)))
        (make-pattern/action (list 'take thing?)
                             (lambda (thing)
                               (person/take player thing)
                               (registry/trigger-times
                                registry difficulty)))
        (make-pattern/action '(go _)
                             (lambda (direction)
                               (person/go player direction)
                               (registry/trigger-times
                                registry difficulty)))
        (make-pattern/action (list 'read scroll?)
                             (lambda (scroll)
                               (person/read player scroll)
                               (registry/trigger-times
                                registry difficulty)))
        (make-pattern/action '(inventory)
                             (lambda ()
                               (person/list-possessions player)
                               (registry/trigger-times
                                registry difficulty)))
        (make-pattern/action '(list possessions)
                             (lambda ()
                               (person/list-possessions player)
                               (registry/trigger-times
                                registry difficulty)))
        (make-pattern/action '(look)
                             (lambda ()
                               (person/look-around player)))
        (make-pattern/action '(look around)
                             (lambda ()
                               (person/look-around player)))
        (make-pattern/action '(say ...)
                             (lambda (stuff)
                               (person/say player stuff)
                               (registry/trigger-times
                                registry difficulty)))))

(define respond-to-using
  (lambda (command p/a-list)
    (cond ((null? p/a-list)
           (display-message '("I don't understand.")))
          ((matches? (pattern (car p/a-list)) command)
           (apply (action (car p/a-list))
                  (substitutions-in-to-match
                   (pattern (car p/a-list))
                   command)))
          (else (respond-to-using command (cdr p/a-list))))))

;; The versions of matches? and substitutions-in-to-match
;; given below not only are after doing various chapter 7
;; exercises, but moreover have an additional feature that a
;; predicate can be used as one of the components of a pattern,
;; in which case it means that at that position in the command,
;; a symbol is needed that is the name of an item in the player's
;; place that satisfies the predicate.

(define matches? 
  (lambda (pattern question)
    (cond ((null? pattern)  (null? question))
          ((not (pair? question)) #f)
          ((equal? (car pattern) '_)
           (matches? (cdr pattern) (cdr question)))
          ((list? (car pattern))
           (if (member (car question) (car pattern))
               (matches? (cdr pattern)
                         (cdr question))
               #f))
          ((equal? (car pattern) '...) #t)
          ((equal? (car pattern) (car question))
           (matches? (cdr pattern)
                     (cdr question)))
          ((procedure? (car pattern))
           (let ((object (object-with-name (car question))))
             (if (and object
                      ((car pattern) object))
                 (matches? (cdr pattern)
                           (cdr question))
                 #f)))
          (else #f))))

(define substitutions-in-to-match
  (lambda (pattern question)
    (cond ((null? pattern)
           (if (null? question)
               '()
               (error 
                "substitutions-in-to-match without a match")))
          ((not (pair? question))
           (error "substitutions-in-to-match without a match"))
          ((equal? (car pattern) '_)
           (cons (car question)
                 (substitutions-in-to-match (cdr pattern)
                                            (cdr question))))
          ((list? (car pattern))
           (if (member (car question) (car pattern))
               (cons (car question)
                     (substitutions-in-to-match (cdr pattern)
                                                (cdr question)))
               (error
                "substitutions-in-to-match without a match")))
          ((equal? (car pattern) '...) (list question))
          ((equal? (car pattern) (car question))
           (substitutions-in-to-match (cdr pattern)
                                      (cdr question)))
          ((procedure? (car pattern))
           (let ((object (object-with-name (car question))))
             (if (and object
                      ((car pattern) object))
                 (cons object
                       (substitutions-in-to-match 
                        (cdr pattern) (cdr question)))
                 (error
                  "substitutions-in-to-match without a match"))))
          (else (error 
                 "substitutions-in-to-match without a match")))))

(define object-with-name
  (lambda (name)
    (let ((objects (filter (lambda (obj)
                             (equal? (named-object/name obj)
                                     name))
                           (place/contents 
                            (person/place player)))))
      (if (or (null? objects)
              (not (null? (cdr objects))))
          #f
          (car objects)))))

;; Review Problems

(person/introduce-self barbara)

(person/introduce-self max-the-person)

(person/introduce-self elvee)

; Hello, I'm barbara.
; I'm known to be fond of chocolate and turning people into frogs.
; Pleased to meet you.

; Hello, I'm max.
; Pleased to meet you.

; Hello, I'm elvee.
; I've got this problem with scrolls.
; Pleased to meet you.

(set-method!
 person-class 'introduce-self
 (lambda (self)
  (let ((name (person/get-name self)))
   (person/say self (list "Hello, I'm" name "."))
   (person/describe-self self)
   (person/say self (list "Pleased to meet you.")))))

(set-method!
 person-class 'describe-self
 (lambda (self)
  'described-self))

(set-method!
 witch-class 'describe-self
 (lambda (self)
  (person/say
  self
  (list "I'm known to be fond of chocolates and turning people to frogs."))))

(instance-of? barbara witch-class)
;Value: #t

(instance-of? barbara person-class)
;Value: #t

(instance-of? barbara place-class)
;Value: #f

(instance-of? lounge place-class)
;Value: #t