;*******************************************************************
;  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* 'future)

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