(in-package :cl-user)
;*******************************************************************
;  MICRO-POLITICS
;
;  A reconstruction, in Common Lisp, of Jaime Carbonell's program in
;  _Inside_Computer_Understanding:_Five_Programs_Plus_Miniatures_
;  Roger Schank and Christopher Riesbeck (eds.)
;  This version does not use any Schankian, conceptual dependency
;  representations.  Propositions about goals, plans and actions are
;  simply formulated as English sentences in list notation (e.g.,
;  (US VOTES FUNDS FOR US TO BUILD SUBMARINES)).
;
;  Warren Sack                
;  MIT Media Lab
;  20 Ames Street, E15-486
;  Cambridge MA 02139
;  wsack@media.mit.edu
;
;  February 1993
;
;*******************************************************************

;  Standard definition of put.
;(defmacro put (x y z)
;    `(setf (get ,x ,y) ,z))

;  Definitions necessary for pattern variables.

(defstruct (pcvar (:print-function print-pcvar)) id)

(defun print-pcvar (var stream depth)
    (declare (ignore depth))
    (format stream "?~s" (pcvar-id var)))

(set-macro-character #\?
                                       #'(lambda (stream char)
                                             (declare (ignore char))
                                             (make-pcvar :id (read stream t nil t)))
                                       t)

(defun pretty-print (x)
    (format t "~%")
    (mapc #'(lambda (w) (format t " ~a" w)) x)
    (format t "."))

(defun process-sentence (sentence)
    (format t "~%Input is")
    (pretty-print sentence)
    (interpret sentence))

; Interpret is the main function.  Given a sentence, it first does
; bottom up inferences (e.g., "voting to do something implies doing
; it"), then it searches the actor's goal tree for a match to the
; last inferred item (e.g., "US increases strength" matches a subgoal
; of "US prevent Russian control of the world"), and finally it looks
; for conflicts and resolutions with the goals of the actor's
; adversary (e.g., "US increase strength conflicts with Russia's
; subgoal of US not increasing strength, which could be resolved if
; Russia stopped the US or if Russia increased its own strength faster.")
(defun interpret (sentence)
    (let ((new-sentence (infer-reason sentence)))
       (format t "~%Inferred goal is ")
       (pretty-print new-sentence)
       (let* ((actor (subject new-sentence)))
          (when actor
               (integrate actor new-sentence)
	       (counter-plan actor new-sentence))
          (if (not actor)
             (format t "~%Error: No actor found in this sentence:~% ~a" new-sentence)))))

; Infer-reason does bottom-up inferences on a sentence.  The inference
; rules are stored under the various predicates (e.g., under vote,
; fund, etc.).  Each new sentence inferred becomes the source of the next
; inference.
(defun infer-reason (current-sentence)
    (let ((next-sentence (find-rule current-sentence)))
       (if next-sentence
          (infer-reason next-sentence)
          current-sentence)))

; Find-rule finds the first rule that infers something from the sentence.
; The rules are stored under the head predicate of the sentence.
(defun find-rule (sentence)
    (find-inferred-sentence sentence (rules-header (main-verb sentence))))

(defun find-inferred-sentence (sentence rules)
    (if rules
       (let ((inferred-sentence (apply-rule sentence (car rules))))
          (if inferred-sentence
             inferred-sentence
	     (find-inferred-sentence sentence (cdr rules))))))

; Apply-rule matches the sentence to the test pattern of the rule.
; If this works it instantiates the action pattern.
(defun apply-rule (sentence rule)
    (let ((bindings (compatible (test-rule rule) sentence)))
       (if bindings
          (instantiate (action-rule rule) (car bindings)))))

; Integrate searches the actor's goal tree for a goal matching the
; sentence.  If one is found it prints a list of the super-goals.
(defun integrate (actor sentence)
    (let* ((goal (get actor 'top-goal))
              (match-goal (if goal (search-goal-tree sentence goal #'compatible))))
       (cond ((null goal)
                    (format t "~%Error: No goals known for ~a" actor))
                   (match-goal
                     (format t "~%~a had goal" actor)
	             (print-super-goals match-goal))
	           (t
                     (format t "~%~a had no higher goals" actor)))))

; Print-super-goals prints the super goals of goal.
(defun print-super-goals (goal)
    (when goal
         (pretty-print (get goal 'form))
         (when (get goal 'super-goal)
              (format t "~%which is a subgoal of")
              (print-super-goals (get goal 'super-goal)))))

; Search-goal-tree finds the first goal in the goal tree that
; satisfies the testfn.  This does a depth-first, left-to-right
; search of the tree.
(defun search-goal-tree (sentence goal testfn)
    (let ((form (get goal 'form)))
       (cond ((null form)
                    nil)
                   ((apply testfn (list form sentence))
                     goal)
	           (t
                     (search-subgoals sentence (get goal 'sub-goals) testfn)))))

(defun search-subgoals (sentence subgoals testfn)
    (if subgoals
       (let ((goal (search-goal-tree sentence (car subgoals) testfn)))
          (if goal
             goal
	     (search-subgoals sentence (cdr subgoals) testfn)))))

; Counter-plan searches the goal tree of X's adversary for a goal
; that conflicts with GX.  If one is found, then the methods Y
; might use against X's goal are looked for.
(defun counter-plan (x gx)
    (format t "~%Looking for conflicts from ~a having goal " x)
    (pretty-print gx)
    (let ((y (get x 'adversary)))
       (if (null y)
          (format t "~%Error: No adversary for ~a" x)
          (let ((gy (find-conflict y gx)))
             (when gy
                  (format t "~%Conflict found -- ~a has goal " y)
                  (pretty-print gy)
	          (find-counter y gx))))))

; Find-conflict searches Y's goal tree for a conflict with GX.
(defun find-conflict (y gx)
    (let ((goal (search-goal-tree gx (get y 'top-goal) #'conflict)))
       (if goal
          (get goal 'form))))

; Data structures and access functions

; These are the representations for "US votes funds to build
; submarines" and "Russia builds submarines."
(defconstant *us-sentence*
    '(us votes funds for us to build submarines))

(defconstant *russia-sentence*
    '(russia to build submarines))

; All the inference rules are of the form
; (<test pattern> <action pattern>)
; When the <test pattern> matches a sentence, the <action pattern> is
; instantiated (according to the bindings from the test match)
; and returned.

(defun test-rule (rule)
    (car rule))

(defun action-rule (rule)
    (cadr rule))

; sentence predicates are atoms with a rules property pointing to a list of
; inference rules.  (add-rules atom rule rule ...) adds inference
; rules to a sentence predicate and (rules-header atom) gets them.

(defmacro add-rules (atom rules)
    `(put ,atom 'rules ,rules))

(defun rules-header (x)
    (if x (get x 'rules)))

; Here are the rules for voting, funding and building.  The first two
; infer the object voted for or funded; i.e., "US voted to fund
; building submarines" means that (1) funding will occur, and
; (2) building will occur.  Build infers that military strength is
; being increased.

(add-rules 'votes '(((?actor votes . ?object)
		                 ?object)))
(add-rules 'funds '(((funds for . ?object)
                                  ?object)))
(add-rules 'build '(((?actor to build ?object)
                                   (?actor to increase military strength))))

; Define US and Russia to be mutual adversaries.

(put 'us 'adversary 'russia)
(put 'russia 'adversary 'us)

; *Counter-rules* are called to find a way to stop a goal.  The
; two here both try to acheive the same goal: that of the
; opponent getting stronger.  One solution is to stop them and
; the other is to beat them to the punch.  The form of a conflict
; rule is (<test> <action>) where the <test> has the form
; (conflict (actor ...) (goal ...)).
(defvar *counter-rules*
    '(((conflict ?actor
                       (?other-actor to increase military strength))
        (if ?actor stops ?other-actor then ?other-actor will not increase military strength))
       ((conflict ?actor
                        (?other-actor to increase military strength))
         (?actor to increase military strength quickly))))

; Find-counter prints all the conflict resolution rules that apply
; to Y's conflict with GX.
(defun find-counter (y gx)
    (let ((pat `(conflict ,y ,gx)))
       (mapc #'(lambda (rule)
	                 (let ((sentence (apply-rule pat rule)))
                            (when sentence
                                 (format t "~%~a could resolve conflict by" y)
                                 (pretty-print sentence))))
                    *counter-rules*)))

; Define-goal-tree (and its subfunction make-goal) allow us to define
; the goal tree for an actor by typing:
; (define-goal-tree actor
;    (top-goal sentence-form
;       (sub-goal sentence-form (sub-goals ...))
;       (sub-goal sentence-form (sub-goals ...))
;       ...))

; The top-level goal is saved under the actor.  Supergoal and subgoal
; links are saved with the goal names.  The sentences are stored under the
; property form.
(defun define-goal-tree (name goal-descriptions)
    (put name 'top-goal (make-goal goal-descriptions nil)))

(defun make-goal (goal-descriptions super-goal)
    (put (car goal-descriptions) 'form (cadr goal-descriptions))
    (put (car goal-descriptions) 'super-goal super-goal)
    (put (car goal-descriptions)
            'sub-goals
            (mapcar #'(lambda (y) (make-goal y (car goal-descriptions)))
	                    (cddr goal-descriptions)))
    (car goal-descriptions))

; We define the US goal tree to say that stopping Russia from
; controlling the world is on top, and the subgoals are the US
; getting stronger and Russia getting weaker.
(define-goal-tree 'us
    '(us-g1 (russia to not control the world)
       (us-g2 (us to increase military strength))
       (us-g3 (russia to not increase military strength))))

; We define the Russian goal tree to say that controlling the world
; is on top, and the subgoals are Russia getting stronger and the US
; getting weaker.
(define-goal-tree 'russia
    '(rus-g1 (russia to control the world)
       (rus-g2 (russia to increase military strength))
       (rus-g3 (us to not increase military strength))))

; Compatible returns true if pat matches sentence.
(defun compatible (pat sentence)
    (unify pat sentence))

(defun conflict (pat sentence)
    (let ((bindings (unify (negate pat) sentence)))
       (if bindings bindings)))

;  Accessor Functions

(defvar *verbs* '(votes funds build))

(defun main-verb (sentence)
    (car (remove nil (mapcar #'(lambda (v)
                                                       (if (member v sentence) v))
                                                  *verbs*))))

(defvar *subjects* '(us russia))

(defun subject (sentence)
    (car (remove nil (mapcar #'(lambda (v)
                                                       (if (member v sentence) v))
                                                  *subjects*))))

;  Mode functions

(defun mode (sentence)
    (if (member 'not sentence)
       'neg
       'pos))

(defun affirm (sentence)
    (if (eq (mode sentence) 'pos)
       sentence
       (remove-if #'(lambda (word)
                                (eq word 'not))
                           sentence)))

(defun negate (sentence)
    (if (eq (mode sentence) 'neg)
       (affirm sentence)
       (let ((sentence-already-negated-p nil))
          (apply #'append
                       (mapcar #'(lambda (word)
                                             (if (eq word 'to)
                                                (cond (sentence-already-negated-p
                                                             (list word))
                                                            (t
                                                              (setq sentence-already-negated-p t)
                                                              '(not to)))
                                                (list word)))
                                       sentence)))))

;  Pattern Unifier
;  This unifier is an adapted version of the unify function which appears
;  in the book _Artificial_Intelligence_Programming_ (2nd ed.)
;  Eugene Chaniak, Drew Msentenceermott, and James Meehan.

(defun unify (pat1 pat2)
    (unify-1 pat1 pat2 nil))

(defun unify-1 (pat1 pat2 sub)
    (cond ((pcvar-p pat1)
                 (var-unify pat1 pat2 sub))
                ((pcvar-p pat2)
                  (var-unify pat2 pat1 sub))
                ((atom pat1)
                  (cond ((eql pat1 pat2) (list sub))
                              (t nil)))
                ((atom pat2) 
                  nil)
                (t
                  (mapcan #'(lambda (sub)
                                         (unify-1 (cdr pat1) (cdr pat2) sub))
                                   (unify-1 (car pat1) (car pat2) sub)))))

(defvar *occurscheck-p* t)

(defun var-unify (pcvar pat sub)
    (cond ((or (eql pcvar pat)
                       (and (pcvar-p pat)
                                 (eql (pcvar-id pcvar)
                                         (pcvar-id pat))))
                 (list sub))
                (t
                  (let ((binding (pcvar-binding pcvar sub)))
                     (cond (binding
                                  (unify-1 (binding-value binding) pat sub))
                                 ((and *occurscheck-p*
                                            (occurs-in-p pcvar pat sub))
                                   nil)
                                 (t
                                   (list (extend-binding pcvar pat sub))))))))

(defun occurs-in-p (pcvar pat sub)
    (cond ((pcvar-p pat)
                 (or (eq (pcvar-id pcvar) (pcvar-id pat))
                       (let ((binding (pcvar-binding pat sub)))
                          (and binding
                                    (occurs-in-p pcvar (binding-value binding) sub)))))
                ((atom pat)
                  nil)
                (t
                  (or (occurs-in-p pcvar (car pat) sub)
                        (occurs-in-p pcvar (cdr pat) sub)))))

(defun pcvar-binding (pcvar alist)
    (assoc (pcvar-id pcvar) alist))

(defun extend-binding (pcvar pat alist)
    (cons (list (pcvar-id pcvar) pat)
               alist))

(defun binding-value (binding) (cadr binding))

(defun pcvar-value (pat sub)
    (let ((binding (pcvar-binding pat sub)))
       (cond ((null binding) 
                    pat)
                   (t
                     (let ((value (binding-value binding)))
                        (cond ((eql value pat)
                                     pat)
                                    (t
                                      (replace-variables value sub))))))))

(defun replace-variables (pat sub)
    (cond ((pcvar-p pat)
                 (pcvar-value pat sub))
                ((atom pat)
                  pat)
                (t
                  (cons (replace-variables (car pat) sub)
                             (replace-variables (cdr pat) sub)))))

(defun instantiate (pat subs)
    (cond ((pcvar-p pat)
                 (let ((entry (assoc (pcvar-id pat) subs)))
                    (if entry 
                       (instantiate (cadr entry) subs)
                       pat)))
                ((atom pat)
                  pat)
                (t
                  (cons (instantiate (car pat) subs)
                             (instantiate (cdr pat) subs)))))


;  Done loading
(format t "~%;Done loading Micro-Politics")