;;-*- Mode: Lisp; 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.)
;
;  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)

(defvar *english-output* nil)

(defun pretty-print (x)
    (if *english-output*
       (say x)
       (pprint x)))

(defun process-cd (cd)
    (format t "~%Input is")
    (pretty-print 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 ")
       (pretty-print new-cd)
       (let* ((actor (filler-role 'actor new-cd)))
          (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
         (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 (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)
    (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-cd*
    '(us votes funds for us to build submarines))

(defconstant *russia-cd*
    '(russia to build 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.

(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)
                                   (increase ?actor 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 miltary-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 ((cd (apply-rule pat rule)))
                            (when cd
                                 (format t "~%~a could resolve conflict by" y)
                                 (pretty-print cd))))
                    *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 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 (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 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)))))

(defun header-cd (x)
    (cond ((member 'votes x)
                 'votes)
                ((member 'fund x)
                  'fund)
                ((member 'build x)
                  'build)
                (t nil)))

;  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)
    (cond ((eq role 'actor)
                 (if (member 'us cd)
                    'us
                    'russia))))

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

;  Mode functions

(defun mode (cd)
    (cdpath '(mode) cd))

;  Affirm/Negate set the mode of a CD to true/false.

(defun affirm (cd)
    (if (member 'pos (mode cd))
       cd
       (setrole 'mode (cons 'pos (remove 'neg (mode cd))) cd)))

(defun negate (cd)
    (if (member 'neg (mode cd))
       (affirm cd)
       (setrole 'mode (cons 'neg (remove 'pos (mode cd))) cd)))

;  maybe makes a CD hypothetical -- doesn't matter if it's true or false.
(defun maybe (cd)
    (if (member 'maybe (mode cd))
       cd
       (setrole 'mode (cons 'maybe (mode cd)) cd)))

;  question/un-question make a CD a question/non-question -- doesn't
;  matter if it's true or false.
(defun question (cd)
    (if (member 'ques (mode cd))
       cd
       (setrole 'mode (cons 'ques (mode cd)) cd)))

(defun un-question (cd)
    (setrole 'mode (remove 'ques (mode cd)) cd))

;  tf adds "transition final" to a CD -- doesn't matter if it's true
;  or false.
(defun tf (cd)
    (if (member 'tf (mode cd))
       cd
       (setrole 'mode (cons 'tf (mode cd)) cd)))

;  future sets a CD to a future time.
(defun future (cd)
    (setrole 'time 'future cd))

;  Path
;
;  cdpath finds the filler at the end of the role list in a CD.
;
;  For example, if
;  CD = (mtrans (actor joe)
;               (object (ptrans (actor joe) 
;                               (object worm)
;                               (from joe)
;                               (to irving))))
;  then
;  (cdpath '(actor) cd) returns joe;
;  (cdpath '(object) cd) returns (ptrans (actor joe) 
;                                        (object worm)
;                                        (from joe)
;                                        (to irving));
;  (cdpath '(object object) cd) returns worm.
;
;  If a role doesn't exist in a CD form, then cdpath returns nil.
(defun cdpath (rolelist cd)
    (if (null rolelist)
       cd
       (cdpath (cdr rolelist) (filler-role (car rolelist) 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))))

;*******************************************************************
;  MICRO-MUMBLE: A micro English generator
;
; This version works with Micro-Politics
;
;  A reconstruction, in Common Lisp, of an English generator used in
;  _Inside_Computer_Understanding:_Five_Programs_Plus_Miniatures_
;  Roger Schank and Christopher Riesbeck (eds.)
;
;  February 1993
;
;*******************************************************************

(defvar *default-tense* 'present)

(defvar *all-objects* '(us world))

;  say prints a CD as an English sentence.  If CD is an mloc of the
;  world, then only the fact itself is said, otherwise the whole mloc
;  is used.  The original CD is returned.  say1 is called with the 
;  infinitive flag off and the say-subject flag on.
(defun say (cd)
    (let ((cd-to-be-said (if (unify-cds '(mloc (val (cp (part world)))) cd)
                                         (cdpath '(con) cd)
                                         cd)))
       (format t "~%")
       (say1 cd-to-be-said 
                  (or (cdpath '(time) cd-to-be-said)
                        *default-tense*)
                  nil
                  t)
       (format t ".")
       cd))

;  say1 prints cd according to the program under the head predicate.
;  If no program is there, the CD is printed with <>s around it.
;  
;  These generation programs are lists of expressions to be evaluated.
;  Attached to primative acts, they are normally concerned with
;  generating subject-verb-object clauses.  Since some of the acts,
;  such as mtrans, want and plan, take subclauses, the generator has to
;  be recursive, so that the atrans program that generates the clause
;  "Joe gave Irving the worm" can also generate the subclause in
;  "Joe planned to give Irving the worm." This means that the programs have
;  to know when to say or not say the subject, when to use the 
;  infinitive form, and what tense to use.
;    subj = true means print the subject,
;    inf = true means use the infinitive form,
;    tense is set to either past, present, or future, or cond (for
;            conditional, i.e., hypothetical)
(defun say1 (cd tense inf subj)
    (if cd
       (let ((say-fun (get (header-cd cd) 'say-fun)))
          (if say-fun 
             (apply say-fun (list cd tense inf subj))
             (format t "~% < ~s > " cd)))))

;  subclause recursively calls say1 with the subconcept at the 
;  endpoint of rolelist.  word, if non-nil, starts the subclause,
;  unless relative-pronoun has a better idea.  Tense is calculated 
;  by sub-tense.
(defun subclause (cd word rolelist tense)
    (if word
       (format t " ~s " (or (relative-pronoun rolelist cd)
                                       word)))
    (let ((subcd (cdpath rolelist cd)))
       (say1 subcd (sub-tense tense subcd) nil t)))

;  sub-tense is given a tense and a CD and picks the tense to use.
;  The given tense is used, except with states (i.e., don't
;  say "he told him where the honey would be" even though conceptually
;  that's right), and with past statements about the future (i.e., say
;  "he said he would" rather than "he said he will").
(defun sub-tense (tense subcd)
    (cond ((is-state subcd)
                 *default-tense*)
                ((and (equal tense 'past)
                           (equal (cdpath '(time) subcd) 'future))
                  'cond)
                (t
                  tense)))

;  relative-pronoun returns the word to start the subclause
;  for the CD at the end of the CD role path.
(defun relative-pronoun (rolelist cd)
    (let ((subcd (cdpath rolelist cd)))
       (cond ((and (equal (header-cd subcd) 'loc)
                             (pcvar-p (cdpath '(val) subcd)))
                    'where)
                   ((pcvar-p (next-subject cd)) 
                     'who)
                   (t
                     nil))))

;  next-subject returns the subject of a subconcept, which is normally
;  the actor slot, except for cont (where it's in the val slot) and
;  mloc (where it's in the part slot of the val slot).
(defun next-subject (cd)
    (let ((subcd (cdpath '(object) cd)))
       (cdpath (case (header-cd subcd)
                         (cont '(val))
                         (mloc '(val part))
                         (t '(actor)))
                      subcd)))

;  infclause calls recursively say1 with the subconcept at the
;  endpoint of rolelist.  An infinitive is printed, and the subject
;  is suppressed.
(defun infclause (cd rolelist subj-flag tense)
    (say1 (cdpath rolelist cd) tense t subj-flag))

;  Store say-funs for each of the CD forms

; increase goes to "increase."
(defun say-increase (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'increase)
    (say-filler cd '(object)))
 
(put 'increase 'say-fun #'say-increase)   

; fund goes to "fund."
(defun say-fund (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'fund)
    (infclause cd '(object) nil 'future))
 
(put 'fund 'say-fun #'say-fund)  

; build goes to "build."
(defun say-build (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'build)
    (say-filler cd '(object)))
 
(put 'build 'say-fun #'say-build)   

; vote goes to "vote."
(defun say-vote (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'vote)
    (say1 (cdpath '(object) cd) 'future inf subj))
 
(put 'vote 'say-fun #'say-vote)   

; control goes to "control."
(defun say-control (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'control)
    (say-filler cd '(object)))
 
(put 'control 'say-fun #'say-control)   

;  atrans may go to either "take" (if actor = to) or "give."
(defun say-atrans (cd tense inf subj)
    (cond ((equal (cdpath '(actor) cd) (cdpath '(to) cd))
                 (say-subj-verb cd tense inf subj '(actor) 'take)
                 (say-filler cd '(object))
                 (say-prep cd 'from '(from)))
                (t
                  (say-subj-verb cd tense inf subj '(actor) 'give)
                  (say-filler cd '(to))
                  (say-filler cd '(object)))))

(put 'atrans 'say-fun #'say-atrans)

;  mtrans may go to either "ask whether" or "tell that"
(defun say-mtrans (cd tense inf subj)
    (cond ((member 'ques (cdpath '(object mode) cd))
                 (say-subj-verb cd tense inf subj '(actor) 'ask)
                 (say-filler cd '(to part))
                 (subclause cd 'whether '(object) 'cond))
                (t
                  (say-subj-verb cd tense inf subj '(actor) 'tell)
                  (say-filler cd '(to part))
                  (subclause cd 'that '(object) (cdpath '(time) cd)))))

(put 'mtrans 'say-fun #'say-mtrans)

;  ptrans may go to either "go" or "move."
(defun say-ptrans (cd tense inf subj)
    (cond ((equal (cdpath '(actor) cd)
                              (cdpath '(object) cd))
                 (say-subj-verb cd tense inf subj '(actor) 'go))
                (t
                  (say-subj-verb cd tense inf subj '(actor) 'move)
                  (say-filler cd '(object))))
    (say-prep cd 'to '(to)))

(put 'ptrans 'say-fun #'say-ptrans)

;  mbuild may go to either "decide to" or "decide that."
(defun say-mbuild (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'decide)
    (cond ((equal (cdpath '(actor) cd)
                              (cdpath '(object actor) cd))
                 (infclause cd '(object) nil 'future))
                (t
                  (subclause cd 'that '(object) 'future))))

(put 'mbuild 'say-fun #'say-mbuild)

;  propel goes to strike
(defun say-propel (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'strike)
    (say-filler cd '(to)))

(put 'propel 'say-fun #'say-propel)

;  grasp may go to either "let go of" or "grab."
(defun say-grasp (cd tense inf subj)
    (cond ((in-mode cd 'tf)
                 (say-subj-verb cd tense inf subj '(actor) 'let)
                 (format t " GO OF  "))
                (t
                  (say-subj-verb cd tense inf subj '(actor) 'grab)))
    (say-filler cd '(object)))

(put 'grasp 'say-fun #'say-grasp)

;  ingest may go to either "eat" or "drink."
(defun say-ingest (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor)
                               (if (equal (cdpath '(object) cd) 'water)
                                  'drink
                                  'eat))
    (say-filler cd '(object)))

(put 'ingest 'say-fun #'say-ingest)

;  plan goes to "plan."
(defun say-plan (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'plan)
    (infclause cd '(object) nil 'future))

(put 'plan 'say-fun #'say-plan)

;  want goes to "want to" -- the third argument of infclause is set to 
;  true if the subject of the subclause is different that the subject
;  of the main clause.
(defun say-want (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'want)
    (infclause cd 
                       '(object) 
                       (not (equal (cdpath '(actor) cd)
                                            (next-subject cd))) 
                       'future))

(put 'want 'say-fun #'say-want)

;  loc goes to "be near."
(defun say-loc (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'be)
    (or (pcvar-p (cdpath '(val) cd))
          (say-prep cd 'near '(val))))

(put 'loc 'say-fun #'say-loc)

;  stop goes to "stop."
(defun say-stop (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'stop)
    (say-filler cd '(object)))

(put 'stop 'say-fun #'say-stop)

;  cont goes to "have."
(defun say-cont (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(val) 'have)
    (say-filler cd '(actor)))

(put 'cont 'say-fun #'say-cont)

;  mloc may go to either "know that", "know whether", or "think that."
(defun say-mloc (cd tense inf subj)
    (say-subj-verb cd 
                               tense 
                               inf 
                               subj 
                               '(val part)
                               (if (relative-pronoun '(con) cd)
                                  'know
                                  'think))
    (subclause cd 'that '(con) *default-tense*))

(put 'mloc 'say-fun #'say-mloc)

;  health goes to "be alive"
(defun say-health (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'be)
    (format t " ALIVE "))

(put 'health 'say-fun #'say-health)

;  smart goes to "be bright"
(defun say-smart (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'be)
    (format t  " BRIGHT "))

(put 'smart 'say-fun #'say-smart)

;  hungry goes to "be hungry"
(defun say-hungry (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'be)
    (format t  " HUNGRY "))

(put 'hungry 'say-fun #'say-hungry)

;  thirsty goes to "be thirsty"
(defun say-thirsty (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'be)
    (format t " THIRSTY "))

(put 'thirsty 'say-fun #'say-thirsty)

;  cause may go to either "x if y" or "if x then y"
(defun say-cause (cd tense inf subj)
    (declare (ignore inf))
    (declare (ignore subj))
    (cond ((in-mode cd 'ques)
                 (subclause cd nil '(conseq) 'future)
                 (format t " IF ")
                 (subclause cd nil '(ante) (case tense
                                                                 (figure 'present)
                                                                 (cond *default-tense*)
                                                                 (t tense))))
                (t
                  (format t " IF ")
                  (subclause cd nil '(ante) 'future)
                  (format t " THEN ")
                  (subclause cd nil '(conseq) 'cond))))

(put 'cause 'say-fun #'say-cause)

;  like goes to "like"
(defun say-like (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'like)
    (say-filler cd '(to)))

(put 'like 'say-fun #'say-like)

;  dominate goes to "dominate"
(defun say-dominate (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'dominate)
    (say-filler cd '(to)))

(put 'dominate 'say-fun #'say-dominate)

;  deceive goes to "deceive"
(defun say-deceive (cd tense inf subj)
    (say-subj-verb cd tense inf subj '(actor) 'deceive)
    (say-filler cd '(to)))

(put 'deceive 'say-fun #'say-deceive)

;  say-filler prints the CD at the end of a CD role path
(defun say-filler (cd rolelist)
    (say-pp (cdpath rolelist cd)))

;  say-pp prints a CD (adds "the" to object).
(defun say-pp (cd)
    (if (member cd *all-objects*)
       (format t " THE "))
    (format t "~s" cd))

;  say-prep prints a preposition plus a CD at the end of a role path,
;  if any exists.
(defun say-prep (cd prep rolelist)
    (let ((subcd (cdpath rolelist cd)))
       (cond (subcd
                    (format t " ~s " prep)
                    (say-pp subcd)))))

;  in-mode tests whether x is in CD's mode.
(defun in-mode (cd x)
    (eq x (cdpath '(mode) cd)))

;  say-neg prints "not" if CD is negative.
(defun say-neg (cd)
    (if (in-mode cd 'neg)
       (format t " NOT")))

;  say-subj-verb prints the subject (unless suppressed by
;  subj = nil, infinitives, or an ?unspec as the subject) and verb, 
;  with auxillary and tensing, if any.  Note that future tense is 
;  treated as an auxillary.
(defun say-subj-verb (cd tense inf subj rolelist infinitive)
    (let ((subject (cdpath rolelist cd)))
       (cond (inf
                    (if subj (say-pp subject))
                    (say-neg cd)
                    (format t " TO ~s " infinitive))
                   (t
                     (if (not (pcvar-p subject)) 
                        (say-pp subject))
                     (let ((plural 
                               (get subject 'plural))
                             (auxilary
                               (cond ((in-mode cd 'maybe)
                                            'might)
                                           ((equal tense 'future)
                                             (if (equal *default-tense* 'past)
                                                'would
                                                'will))
                                           ((equal tense 'cond)
                                             'would)
                                           ((and (in-mode cd 'neg)
                                                      (not (equal infinitive 'be)))
                                             'do))))
                        (cond (auxilary
                                     (say-tense cd tense inf subj auxilary plural)
                                     (format t " ")
                                     (say-neg cd)
                                     (format t " ~s " infinitive))
                                    (t
                                      (say-tense cd tense inf subj infinitive plural)
                                      (format t " ")
                                      (if (equal infinitive 'be) (say-neg cd)))))))))

;  say-tense prints a verb, with tense and number inflection.
;  Conjugations of irregular verbs are stored under the past and present
;  properties of the verb, in the format (singular plural) for each.
;  For regular verbs, say-tense adds "d", "ed", or "s" as appropriate.
(defun say-tense (cd tense inf subj infinitive plural)
    (declare (ignore cd))
    (declare (ignore inf))
    (declare (ignore subj))
    (let ((tense-forms (get infinitive tense)))
       (format t " ")
       (cond (tense-forms
                    (format t "~s" (if plural
                                              (cadr tense-forms)
                                              (car tense-forms))))
                   (t
                     (format t "~s" infinitive)
                     (case tense
                         (past
                           (if (not (or (equal (lastchar infinitive) #\E)
                                              (equal (lastchar infinitive) #\e)))
                              (format t "E"))
                           (format t "D "))
                         (present
                           (if (not plural)
                              (format t "S "))))))))

;  lastchar returns that last character in x
(defun lastchar (x)
    (car (last (explode x))))

(defun explode (x)
    (coerce (princ-to-string x) 'list))

;  is-state returns non-nil if CD is one of the state forms.
(defun is-state (cd)
    (member (header-cd cd)
                      '(loc 
                         mloc 
                         cont 
                         like 
                         deceive 
                         dominate 
                         hungry 
                         thristy 
                         health 
                         smart)))

;  Generator Dictionary
;
;  Set the past and/or present tenses for irregular verbs.
;  Each tense is of the form (singular plural).

(put 'be 'past '(was were))
(put 'be 'present '(is are))
(put 'do 'past '(did did))
(put 'do 'present '(does do))
(put 'drink 'past '(drank drank))
(put 'eat 'past '(ate ate))
(put 'give 'past '(gave gave))
(put 'go 'past '(went went))
(put 'go 'present '(goes go))
(put 'grab 'past '(grabbed grabbed))
(put 'have 'past '(had had))
(put 'have 'present '(has have))
(put 'know 'past '(knew knew))
(put 'let 'past '(let let))
(put 'might 'past '(might might))
(put 'might 'present '(might might))
(put 'plan 'past '(planned planned))
(put 'strike 'past '(struck struck))
(put 'take 'past '(took took))
(put 'tell 'past '(told told))
(put 'think 'past '(thought thought))
(put 'build 'past '(built built))
(put 'stop 'past '(stopped stopped))

(put 'berries 'plural t)
(put 'submarines 'plural t)

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