;*******************************************************************
;  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.)
;
;  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 process-cd (cd)
    (format t "~%Input is")
    (pprint cd)
    (interpret cd))

; Interpret is the main function.  Given a cd, 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 (cd)
    (let ((new-cd (infer-reason cd)))
       (format t "~%Inferred goal is ")
       (pprint new-cd)
       (let* ((actor-name (filler-role 'actor new-cd))
                 (actor (if (consp actor-name) (header-cd actor-name) actor-name)))
          (when actor
               (integrate actor new-cd)
	       (counter-plan actor new-cd))
          (if (not actor)
             (format t "~%Error: No actor found in this cd:~% ~a" new-cd)))))

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

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

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

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

; Integrate searches the actor's goal tree for a goal matching the
; cd.  If one is found it prints a list of the super-goals.
(defun integrate (actor cd)
    (let* ((goal (get actor 'top-goal))
              (match-goal (if goal (search-goal-tree cd 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
         (pprint (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 (cd goal testfn)
    (let ((form (get goal 'form)))
       (cond ((null form)
                    nil)
                   ((apply testfn (list form cd))
                     goal)
	           (t
                     (search-subgoals cd (get goal 'sub-goals) testfn)))))

(defun search-subgoals (cd subgoals testfn)
    (if subgoals
       (let ((goal (search-goal-tree cd (car subgoals) testfn)))
          (if goal
             goal
	     (search-subgoals cd (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)
    (pprint 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)
                  (pprint 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))))

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

; Data structures and access functions

; These are the representations for "US votes funds to build
; submarines" and "Russia builds submarines."
(defconstant us-cd
    '(vote (actor us)
       (object (fund (actor us)
                               (object (build (actor us)
                                                        (object submarines)))))))

(defconstant russia-cd
    '(build (actor russia)
       (object submarines)))

; All the inference rules are of the form
; (<test pattern> <action pattern>)
; When the <test pattern> matches a cd, 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))

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

(defun 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 'vote '(((vote (actor ?x) (object ?y))
		                 ?y)))
(add-rules 'fund '(((fund (actor ?x) (object ?y))
                                  ?y)))
(add-rules 'build '(((build (actor ?x) (object ?y))
                                   (increase (actor ?x)
		                                     (object military-strength)
		                                     (mode pos)))))

; 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 ...)).

(defconstant *counter-rules*
    '(((conflict (actor ?x)
                       (goal (increase (actor ?y)
                                                    (object military-strength)
                                                    (mode pos))))
        (cause (ante (do (actor ?x)))
                      (conseq (increase (actor ?y)
                                                        (object military-strength)
                                                        (mode neg)))))
       ((conflict (actor ?x)
                        (goal (increase (actor ?y)
                                                     (object military-strength)
                                                     (mode pos))))
         (increase (actor ?x)
                           (object military-strength)
                           (manner fast)))))

; 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 cd-form
;       (sub-goal cd-form (sub-goals ...))
;       (sub-goal cd-form (sub-goals ...))
;       ...))

; The top-level goal is saved under the actor.  Supergoal and subgoal
; links are saved with the goal names.  The cds 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 (control (actor russia) (object world) (mode neg))
       (us-g2 (increase (actor us) (object military-strength) (mode pos)))
       (us-g3 (increase (actor russia) (object military-strength) (mode neg)))))

; 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 (control (actor russia) (object world)) ;;; should this include a (mode pos)?
       (rus-g2 (increase (actor russia) (object military-strength)
	                               (mode pos)))
       (rus-g3 (increase (actor us) (object military-strength) (mode neg)))))

; Compatible returns true if pat matches cd.
(defun compatible (pat cd)
    (unify-cds pat cd))

; Conflict returns true if pat conflicts with cd.  Defining conflict
; is an open problem.  Here we make the mode of pat a variable and
; match pat against cd.  If they match but the mode in cd is not
; equal to the mode in pat, then a conflict exists.
(defun conflict (pat cd)
    (let* ((original-pat pat)
              (var-pat (setrole 'mode '?mode pat))
              (bindings (unify-cds var-pat cd)))
       (if (and bindings
                     (not (equal (pcvar-value '?mode (car bindings))
                                          (filler-role 'mode original-pat))))
          bindings)))

;  CD Functions

;  is-cd-p determines whether a given sexpr is a CD.
(defun is-cd-p (x)
    (and (listp x)
              (atom (header-cd x))
              (list-of-role-filler-pairs-p (roles-cd x))))

(defun list-of-role-filler-pairs-p (x)
    (or (null x)
          (and (listp x)
                    (listp (car x))
                    (atom (role-pair (car x)))
                    (list-of-role-filler-pairs-p (cdr x)))))

;  header-cd gets the head act of a CD form.
(defun header-cd (x)
    (car x))

;  roles-cd gets the list of role-pairs of a CD form.
(defun roles-cd (x)
    (cdr x))

;  Role-pairs have the form (role filler).
;  role-pair returns the role.
(defun role-pair (x)
    (car x))

;  filler-pair returns the filler.
(defun filler-pair (x)
    (cadr x))

;  A filler for a role is found by looking for the role name in the CD,
;  and returning the filler if a pair is found.
(defun filler-role (role cd)
    (if (listp cd)
       (let ((pair (assoc role (roles-cd cd))))
          (if pair (filler-pair pair)))))

;  setrole makes a new CD form with (role filler) added
;  or replacing the old (role ...) pair.
(defun setrole (role filler cd)
    (cons (header-cd cd)
               (cons (list role filler)
                          (remove-if #'(lambda (pair)
                                                   (eq (car pair) role))
                                              (roles-cd cd)))))

;  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 McDermott, 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)))))

;  CD Unifier
;  This replaces the less-general CD pattern matcher that was
;  used in the original Micro-Politics program.  This unifier
;  allows pattern variables to appear on both of the
;  expressions to be compared while a pattern matcher
;  only allows variables to appear in one of the expressions.

(defun unify-cds (cd1 cd2)
    (unify-cds-1 cd1 cd2 nil))

(defun unify-cds-1 (cd1 cd2 sub)
    (and (eq (header-cd cd1) (header-cd cd2))
              (unify-pairs (roles-cd cd1) (roles-cd cd2) sub)))

;  unify-pairs sees if the roles and fillers of a CD can
;  be matched together.  It is more complicated than the
;  function unify-1 given above because (1) the role-filler pairs
;  do not need to be in the same order in the two CDs being
;  compared; (2) a missing pair in one CD means that that CD
;  is more general than the other CD and can, thus, be matched
;  against it; and, finally, (3) the filler of a pair can be a CD,
;  and most fillers which are lists are CDs, however, fillers which
;  are "modes" are the exception; they are fillers which are lists,
;  but are not CDs, so a special exception has to be made for them
;  in the unification procedure below.
(defun unify-pairs (pairs1 pairs2 sub)
    (if (or (null pairs1) (null pairs2))
       (list sub)
       (let* ((role 
                  (role-pair (car pairs1)))
                 (pair-from-pairs2
                   (assoc role pairs2))
                 (rest-of-pairs-from-pairs2
                   (remove-if #'(lambda (pair)
                                            (equal (role-pair pair) role))
                                       pairs2))
                 (newsubs
                   (cond ((eq role 'mode)
                                (unify-1 (car pairs1) pair-from-pairs2 sub))
                               ((and pair-from-pairs2
                                          (or (pcvar-p (cadr pair-from-pairs2))
                                                (atom (cadr pair-from-pairs2))))
                                 (unify-1 (car pairs1) pair-from-pairs2 sub))
                               ((and pair-from-pairs2
                                          (or (pcvar-p (cadr (car pairs1)))
                                                (atom (cadr (car pairs1)))))
                                 (unify-1 (car pairs1) pair-from-pairs2 sub))
                               (pair-from-pairs2
                                 (unify-cds-1 (car pairs1) pair-from-pairs2 sub))
                               (t
                                 (list sub)))))
          (mapcan #'(lambda (newsub)
                                 (unify-pairs (cdr pairs1)
                                                       rest-of-pairs-from-pairs2
                                                       newsub))
                           newsubs))))

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