;**********************************************************
;
;  Lisp functions for Class ECE 578 Intelligent Robotics
;  at PSU Portland State University
;
;  HOMEWORK Week 2
;
;  Author: Reto Toengi (RT)
;
;  Created: 26 Jan 2005
;  Modified: 31 Jan 2005
;
;**********************************************************

;----------------------------------------------------------
;
; VARIANT B.
; 1. The sentence is a list of words. There is a group of questions that start from an
;    informing sentence, for instance "THE HAMMER IS ON THE DESK, ISN'T IT?" or
;    "MARY HAS LEFT THIS ROOM, HASN'T SHE?).
; 2. The program has to recognize the type of such question by checking what is the
;    pattern ending the question. These patterns are like (ISN'T IT), (HASN'T SHE), (IS
;    THAT TRUE), (DOES NOT SHE), (HAS HE).
; 3. Knowing the type of such sentence, the first part of the sentence, like (THE
;    HAMMER IS ON THE DESK) has to be parsed and confirmed in the data base is it
;    true or not.
; 4. Before asking this kind of questions by the human, the program investigates the
;    situation by asking questions to the human. For instance (WHERE IS THE
;    HAMMER), (WHAT IS ON THE DESK), etc. So, in the first phase the initiative of
;    dialog is by the computer who asks questions to create the data base of facts. When
;    the data base is created, the computer gives initiative to the user who asks questions
;    of the type B.
; 5. The program should answer with full sentences, like (YES, YOU ARE RIGHT, THE
;    HAMMER IS ON THE DESK), or (NO, YOU ARE WRONG, THE HAMMER IS
;    NOT ON THE DESK, THE HAMMER IS ON THE BED).
;----------------------------------------------------------
(setq *object-list* '((Mary . f)
                      (Paul . m)
                      (table . o)
                      (chair . o)
                      (hammer . o)
                      (lamp . o)
                      (radio . o))) ;------ Objects
(setq *pronoun-list* '((f . she)
                       (m . he)
                       (o . it)))   ;------ pronoun
(setq *adverb-list* '((is . loc)
                      (has . act)
                      (does . act)));------ positive adverbs
(setq *nadverb-list* '((isn . loc)
                       (hasn . act)
                       (doesn . act)));------ negative verbs
(setq *loc-ident-list* '(at
                         in
                         on
                         under
                         ontop
                         to
                         left
                         right
                         outside
                         inside
                         behind
                         infront
                         before
                         next
                         nextto
                         above
                         underneath
                         here
                         there
                         over))
;----------------------------------------------------------
; question routines
;----------------------------------------------------------
(defun ask-loc (obj)
 (let ((ol *object-list*))
 (format t "Where is ~S?~%" (obj-full ol obj))))

(defun ask-job (name)
 (format t "What does ~S?~%" name))

(defun w-loc (obj loc)
 (setf (get obj 'loc) loc))

(defun w-verb (obj verb)
 (setf (get obj 'verb) verb))

(defun w-name (obj name)
 (let ((nls name)
       (type (cdr-obj *object-list* obj)))
  (or (listp nls) (setq nls (list nls)))
  (and (equal type 'o) (setq nls (cons 'the nls)))
  (setf (get obj 'name) nls)
))

(defun obj-full (ls obj)
 (cond ((null ls) '(nil))
       ((equal (caar ls) obj) (cond ((equal (cdr (car ls)) 'f) (list (caar ls)))
                                    ((equal (cdr (car ls)) 'm) (list (caar ls)))
                                    (T (list 'the (caar ls)))
                              ))
       (T (obj-full (cdr ls) obj))
 )
)

(defun w-all (obj in)
 (let ((frase in)
       (sub nil)
       (verb nil)
       (loc nil))
  (setq sub (car frase))
  (setq frase (cdr frase))
  (setq verb (car frase))
  (setq frase (cdr frase))
  (setq loc (car frase))
  (or (null loc)
      (and (listp loc) (car loc) (w-loc obj loc))
      (and (atom loc) (w-loc obj (list loc))))
  (or (and (null verb) (null (get obj 'verb)) (w-verb obj '(is)))
      (and (listp verb) (car verb) (w-verb obj verb))
      (and (atom verb) (w-verb obj (list verb))))
  (cond ((null sub) (w-name obj (list obj)))
        ((listp sub) (w-name obj (list obj)))
        (T (w-name obj (list sub))))
 )
)

(defun question (ls)
 (let ((atr (cdr (car ls)))
       (obj (caar ls))
       (in nil)
       (in2 nil)
       (sub-in nil)
      )
  (cond ((null obj) (msg-inpend))
        ((equal atr 'o) (progn
                          (setq in (q-o obj))
                          (cond ((inp-exit in) in)
                                ((null in) nil)
                                (T (progn
                                    (and (null (cadr in))
                                         (setq in (list (car in) '(is) (caddr in))))
                                    (w-all obj in)
                                    (question (cdr ls))
                                   )))
                        ))
        (T (progn
            (setq in (q-o obj))
            (cond ((inp-exit in) in)
                  ((null in) nil)
                  (T (progn
                      (w-all obj in)
                      (setq in2 (q-fm obj))
                      (and (null (cadr in2))
                           (setq in2 (list (car in2) '(is) (caddr in2))))
                      (w-verb obj (cadr in2))
                      (question (cdr ls))
                     ))
            )
           )
         )
  )
 )
)

(defun init-q ()
 (let
  ((ls (cdr-list *object-list* ()))
  )
  (question ls)
 )
)

(defun q-o (obj)
 (let ((in nil))
  (ask-loc obj)
  (setq in (inp))
  (cond ((null in) (q-o obj))
        ((inp-exit in) in)
        (T (setq in (extract in))))
 )
)

(defun q-fm (obj)
 (let ((in nil))
  (ask-job obj)
  (setq in (inp))
  (cond ((null in) (q-fm obj))
        ((inp-exit in) in)
        (T (setq in (extract in))))
 )
)

;----------------------------------------------------------
; knowledge routines
;----------------------------------------------------------
(defun knowledge (ls)
 (let ((atr (cdr (car ls)))
       (obj (caar ls))
      )
  (cond ((null ls) (format t "This is all I know.~%"))
        (T (progn
             (format t "~S ~S ~S~%" (get obj 'name) (get obj 'verb) (get obj 'loc))
             (knowledge (cdr ls))
        ))
  )
 )
)

;----------------------------------------------------------
; question-answer routines
;----------------------------------------------------------
(defun q-a ()
 (let ((in nil))
  (msg-input)
  (setq in (inp))
  (or (inp-exit in) (answ-q in) (q-a))
 )
)

(defun c-sub (sub subp)
 (let ((sub sub)
       (subp subp)
       (pron nil)
       (type nil)
       (ol *object-list*)
       (pl *pronoun-list*))
  (and (listp sub) (setq sub (car sub)))
  (and (listp subp) (setq subp (car subp)))
  (setq pron (intersection (list sub) (car-list ol ())))
  (cond ((null pron) (equal pron subp))
        (T (progn
             (setq pron (cdr-obj pl (cdr-obj ol sub)))
             (equal pron subp)
           )))
))

(defun c-verb (verb sub)
 (let ((verb verb)
       (sub sub))
  (or (listp verb) (setq verb (list verb)))
  (and (listp sub) (setq sub (car sub)))
  (equal verb (get sub 'verb))
))

(defun c-loc (loc sub)
 (let ((loc loc)
       (sub sub))
  (or (listp loc) (setq loc (list loc)))
  (and (listp sub) (setq sub (car sub)))
  (equal loc (get sub 'loc))
))

(defun answ-q (in)
 (let ((main in)
       (subp nil)
       (ending nil)
       (answ nil)
       (pl *pronoun-list*)
      )
  (setq subp (last main))
  (cond ((not (member (car subp) (cdr-list pl ()))) (progn
                                                                 (msg-ending)
                                                                 (q-a)
                                                                ))
        (T (progn
            (setq ending (p-ending main))
            (setq main (cut-off main (length ending)))
            (setq answ (check-frase main ending))
            (cond ((equal answ 'loc)
                       (format t "You are wrong~%~S,~%~S~%~%" (wrong-answ-loc main) (right-answ main)))
                  ((equal answ 'verb)
                       (format t "Almost correct~%~S~%~%" (right-answ main)))
                  ((equal answ 'wverb)
                       (format t "You might be correct that~%~S~%~%" main))
                  ((equal answ 'nloc)
                       (format t "You are wrong~%~S~%~%" (right-answ main)))
                  ((equal answ 'nverb)
                       (format t "You are wrong~%~S~%~%" (right-answ main)))
                  ((equal answ 'neg)
                       (format t "Your ending does not fit the verb construction~%~%"))
                  ((equal answ 'pron)
                       (format t "You used the wrong pronoun!~%~%"))
                  (T (format t "You are rigth, ~S~%~%" main)))
           ))
  )
 )
)

(defun check-frase (frase ending)
 (let ((main (extract frase))
       (psub (last ending))
       (neg nil))
  (setq neg (< (length ending) 3))
  (cond ((not (c-sub (car main) psub)) 'pron)
        ((null neg) (check-positive main))
        (T (check-negative main))
  )
 )
)

(defun check-negative (main)
 (let ((sub (caar main))
       (loc (car (last main)))
       (verb (cadr main))
       (nloc nil)
       (nverb nil))
  (and (equal (car (last verb)) 'not) (setq nloc T))
  (and (member (cadr verb) '('t not) :test #'equal) (setq nverb T))
  (cond ((not (or nloc nverb)) 'neg)
        (T (cond ((and (not (null (car loc))) nloc (c-loc loc sub)) 'nloc)
                 ((and (not (null (car loc))) (not nloc) (not (c-loc loc sub))) 'nloc)
                 ((equal verb '(is)) nil)
                 ((equal (get sub 'verb) '(is)) 'wverb)
                 ((and nverb (c-verb verb sub)) 'nverb)
                 ((and (not nverb) (not (c-verb verb sub))) 'nverb)
                 (T nil))))
 )
)

(defun check-positive (main)
 (let ((sub (caar main))
       (loc (car (last main)))
       (verb (cadr main)))
  (cond ((and (not (null (car loc))) (not (c-loc loc sub))) 'loc)
        ((equal verb '(is)) nil)
        ((equal (get sub 'verb) '(is)) 'wverb)
        ((not (c-verb verb sub)) 'verb)
        (T nil))
 )
)

(defun wrong-answ-loc (frase)
 (let ((main (extract frase))
       (verb nil))
  (setq verb (cadr main))
  (cond ((< (length verb) 2) (list (car main) (cons (car verb) '(not)) (car (last main))))
        ((not (member (cadr verb) '('t not))) (list (car main) (cons (car verb) (cons 'not (cdr verb))) (car (last main))))
        (T (list (car main) (cons 'is '(not)) (car (last main)))
        )
  )
 )
)

(defun wrong-answ-verb (frase)
 (let ((main (extract frase))
       (verb nil))
  (setq verb (cadr main))
  (cond ((< (length verb) 2) (list (car main) (cons (car verb) '(not)) (car (last main))))
        ((not (member (cadr verb) '('t not))) (list (car main) (cons (car verb) (cons 'not (cdr verb))) (car (last main))))
        (T (list (car main) (cons 'is '(not)) (car (last main)))
        )
  )
 )
)

(defun right-answ (frase)
 (let ((sub (caar (extract frase))))
  (list (list sub) (get sub 'verb) (get sub 'loc))
 )
)
;----------------------------------------------------------
; input routines
;----------------------------------------------------------
(defun inp ()
 (let ((in (read)))
  (cond ((inp-exit in) '(quit))
        ((null in) (progn (msg-list) (inp)))
        ((atom in) (progn (msg-list) (inp)))
        ((listp in) in)
        (T (progn (msg-list) (inp)))
  )
 )
)

(defun inp-exit (in)
 (or (equal in 'quit) (equal in '(quit)) (equal in 'exit) (equal in '(exit))))

;----------------------------------------------------------
; extraction routines
;----------------------------------------------------------
(defun extract (in)
 (let ((frase in)
       (sub nil)
       (verb nil)
       (loc nil))
  (setq loc (p-loc frase))
  (or (null loc) (setq frase (p-until frase (car loc) ())))
  (setq sub (p-sub frase))
  (setq verb (p-verb frase))
  (or (listp verb) (setq verb (list verb)))
  (or (listp sub) (setq sub (list sub)))
  (list sub verb loc)
 )
)

(defun p-loc (ls)
 (let ((loc-ident nil)
       (loc nil)
      )
  (setq loc-ident (car (intersection ls *loc-ident-list*)))
  (or (null loc-ident) (setq loc (cons loc-ident (p-after ls loc-ident))))
  loc
 )
)

(defun p-verb (ls)
 (let ((sub nil)
       (loc-ident nil)
       (verb nil)
      )
  (setq loc-ident (car (last (intersection *loc-ident-list* ls))))
  (cond ((null loc-ident) (setq verb ls))
        (T (setq verb (p-until ls loc-ident ()))))
  (setq sub (p-sub verb))
  (cond ((null sub) nil)
        (T (setq verb (p-after ls sub)))
  )
  (and (member loc-ident verb)
   (setq verb (reverse (cdr (reverse verb))))
  )
  verb
 )
)

(defun p-sub (ls)
 (let ((sub nil)
       (sub-ls nil)
       (sub-temp nil)
       (ol *object-list*)
       (pl *pronoun-list*))
  (setq sub-ls (list (cdr-obj pl 'o)))
  (setq sub-temp (car-list ol ()))
  (setq sub-temp (list-car-rem sub-temp ol 'm))
  (setq sub-temp (list-car-rem sub-temp ol 'f))
  (setq sub-ls (append sub-temp sub-ls))
  (setq sub-temp (cdr-list pl ()))
  (setq sub-temp (list-cdr-rem sub-temp pl 'o))
  (setq sub-ls (append sub-temp sub-ls))
  (setq sub-temp (car-list ol ()))
  (setq sub-temp (list-car-rem sub-temp ol 'o))
  (setq sub-ls (append sub-temp sub-ls))
  (setq sub (car (intersection sub-ls ls)))
  sub
 )
)

(defun p-ending (ls)
 (let ((end nil)
       (el nil))
  (setq el (- (length ls) 3))
  (and (minusp el) (setq el 0))
  (setq end (p-after ls (nth el ls)))
  (cond ((null ls) nil)
        ((member (car end) '('t not) :test #'equal)
           (setq end (cons (nth el ls) end))))
  end
 )
)

(defun p-until (ls obj nls)
 (let ((el (car ls)))
  (cond ((null ls) (reverse nls))
        ((null obj) (reverse nls))
        ((equal el obj) (reverse (cons el nls)))
        (T (p-until (cdr ls) obj (cons el nls))))
 )
)

(defun p-after (ls obj)
 (let ((el (car ls)))
  (cond ((null ls) ls)
        ((null obj) ls)
        ((equal el obj) (cdr ls))
        (t (p-after (cdr ls) obj)))
 )
)

(defun cut-off (ls nr)
 (cond ((null ls) ls)
       ((zerop nr) ls)
       (T (cut-off (reverse (cdr (reverse ls))) (- nr 1))))
)
;----------------------------------------------------------
; list routines
;----------------------------------------------------------
(defun car-list (ls obj-ls)
 (cond ((null ls) obj-ls)
       ((not (null (caar ls))) 
        (car-list (cdr ls) (cons (caar ls) obj-ls)))
       (T (car-list (cdr ls) obj-ls))
 )
)

(defun cdr-list (ls obj-ls)
 (cond ((null ls) obj-ls)
       ((not (null (caar ls))) 
        (cdr-list (cdr ls) (cons (cdr (car ls)) obj-ls)))
       (T (cdr-list (cdr ls) obj-ls))
 )
)

(defun car-obj (ls obj)
 (cond ((null ls) nil)
       ((equal (cdr (car ls)) obj) (caar ls))
       (T (car-obj (cdr ls) obj))
 )
)

(defun cdr-obj (ls obj)
 (cond ((null ls) nil)
       ((equal (caar ls) obj) (cdr (car ls)))
       (T (cdr-obj (cdr ls) obj))
 )
)

(defun list-car-rem (ls comp-ls type)
 (let ((next (car ls))
       (rest (cdr ls))
       (next-type nil))
  (setq next-type (cdr-obj comp-ls next))
  (cond ((null next) nil)
        ((not (equal next-type type))
            (cons next (list-car-rem rest comp-ls type)))
        (T (list-car-rem rest comp-ls type)))
 )
)

(defun list-cdr-rem (ls comp-ls type)
 (let ((next (car ls))
       (rest (cdr ls))
       (next-type nil))
  (setq next-type (car-obj comp-ls next))
  (cond ((null next) nil)
        ((not (equal next-type type))
            (cons next (list-car-rem rest comp-ls type)))
        (T (list-car-rem rest comp-ls type)))
 )
)

;----------------------------------------------------------
; messages routines
;----------------------------------------------------------
(defun msg-input ()
 (format t "Write your question in the form isn't it, doesn't he in parenthesis.~%(quit) lets you exit the cycle.~%"))

(defun msg-inpend ()
 (format t "Thanks, there is no more question.~%"))

(defun msg-list ()
 (format t "Your input must be a list!~%(quit) for exit process. Try again~%"))

(defun msg-parcing ()
 (format T "Sentence parcing failed~%"))

(defun msg-ponoun ()
 (format T "Pronoun matching failed! Your statment is not consistent~%"))

(defun msg-ending ()
 (format T "Your ending is not correct!~%"))

(defun answ-verb-wrong ()
)

;----------------------------------------------------------
; main routines
;----------------------------------------------------------
(defun main ()
 (let ((fb nil)
       (ol *object-list*))
  (setq fb (question *object-list*))
  (or (equal fb '(quit)) (knowledge *object-list*))
  (or (equal fb '(quit)) (q-a))
))