; McSAM is a micro implementation of SAM, the Script Applier Mechanism,
; and is copied from the paper "MICRO-SAM AND MICRO-ELI, EXERCISES IN
; POPULAR COGNITIVE MECHANICS", by Christopher K. Riesbeck and Eugene 
; Charniak, of September 1978 (Research Report #139, Yale University,
; Department of Computer Science).

;======================================================================
; Included here is an excerpt from the paper referenced above:
; 
; 	"The meaning of a sentence is represented using Conceptual
; Dependency (Schank 1975).  Conceptual Dependency (CD) is based on a
; small set of predicates, called acts, describing basic everyday
; activities such as moving things and transferring information.  Each
; predicate is associated with a standard set of roles or arguments.  In
; addition to the acts, there are also states which acts can bring about
; or change, and large knowledge structures, such as scripts, which are
; built from combinations of acts and states.
; 
; 	"There are 11 primitive acts in Conceptual Dependency, but only
; the following are used by McSAM and McELI examples in this report:
; 
;    1. PTRANS -- an actor moves an object to a location from a 
; 	location.  In LISP we write
; 		(PTRANS (ACTOR actor) (OBJECT object)
; 			(TO location1) (FROM location2))
; 
;    2. ATRANS -- an actor transfers possession of an object to
; 	someone from someone.  In LISP we write
; 		(ATRANS (ACTOR actor) (OBJECT object)
; 			(TO person1) (FROM person2))
; 
;    3. MTRANS -- an actor tells someone a conceptualization.  In
; 	LISP we write
; 		(MTRANS (ACTOR actor) (OBJECT object) (TO person))
; 
;    4. INGEST -- an actor eats (or drinks) something.  In LISP we
; 	write
; 		(INGEST (ACTOR actor) (OBJECT object))
; 
;======================================================================

; First, define some of the useful tools available in their LISP.

@LOOP

;***********************************************************************
;	DATA STRUCTURES
;***********************************************************************

; A story is a list of lines and a line is a list of statements.
; A statement is a predicate (PTRANS, PERSON, etc.) plus zero or more
; arguments (e.g., (ACTOR JOHN1)).  An example of a 3-line story is:

(SETQ STORY-CDS
   '(
      (	% Jack went to the store.
         (STORE (OBJECT STORE1))
         (PERSON (OBJECT JACK1))
         (PTRANS (ACTOR JACK1) (OBJECT JACK1) (TO STORE1))
      )
      (	% He got a kite
         (KITE (OBJECT KITE1))
         (ATRANS (OBJECT KITE1) (TO JACK1))
      )
      (	% He went home.
         (HOUSE (OBJECT HOUSE1))
         (PTRANS (ACTOR JACK1) (OBJECT JACK1) (TO HOUSE1]

; The form (predicate role-pair role-pair...) is used to represent
; CD structures -- (PTRANS (ACTOR JACK1) (OBJECT JACK1) (TO STORE1))
; -- script binding forms -- (SHOPPING (SHOPPER JACK1) (STORE STORE1))
; -- and the pattern matcher's binding lists

; PREDICATE:STM gets the predicate of a CD form
; ARGUMENTS:STM gets the list of roles of a CD form

(DE PREDICATE:STM (X) (CAR X))
(DE ARGUMENTS:STM (X) (CDR X))

; role-paris have the form (role filler) -- ROLE:PAIR returns the role
; and FILLER:PAIR returns the filler

(DE ROLE:PAIR (X) (CAR X]
(DE FILLER:PAIR (X) (CADR X]

; A script is a list of events.  An event is a CD form, which may
; have references to the roles of the script, as in
; (PTRANS (ACTOR ?SHOPPER) ...).  All such references to script
; roles (also called variables) start with a question mark ("?").
; This is converted internally to (*VAR* role-name), so ?FOO
; becomes (*VAR* FOO).

; Below are functions for 1) making this conversion (at read time),
; 2) deciding if something is a variable, and 3) retrieving the 
; name of a variable (e.g., FOO) from the form (*VAR* FOO).

(DRM ? (LIST '*VAR* (READ]
(LEX "?" 'CHRCLMONOP)	% special to this implementation
(DE IS-VAR (X) (AND (CONSP X) (EQ (CAR X) '*VAR*]
(DE NAME:VAR (X) (AND (CONSP X) (CONSP (CDR X)) (CADR X]

; Script names are atoms with an EVENTS property of the atom pointing
; to a list of events

(DE EVENTS:SCRIPT (X) (AND X (GET X 'EVENTS]

; For example, this is the shopping script:

(DEFPROP SHOPPING
   (
      (PTRANS (ACTOR ?SHOPPER) (OBJECT ?SHOPPER) (TO ?STORE))
      (PTRANS (ACTOR ?SHOPPER) (OBJECT ?BOUGHT) (TO ?SHOPPER))
      (ATRANS
         (ACTOR ?STORE) (OBJECT ?BOUGHT)
         (FROM ?STORE) (TO ?SHOPPER)
      )
      (ATRANS
         (ACTOR ?SHOPPER) (OBJECT MONEY)
         (FROM ?SHOPPER) (TO ?STORE)
      )
      (PTRANS
         (ACTOR ?SHOPPER) (OBJECT ?SHOPPER)
         (FROM ?STORE) (TO ?ELSEWHERE)
      )
   )
   EVENTS
)

; Some predicates have associated scripts.  For example, the SHOPPING
; script is associated with STORE.  The script is stored under
; the ASSOCIATED-SCRIPT property of the predicate.

(DE ASSOCIATED-SCRIPT:PREDICATE (X)
   (GET X 'ASSOCIATED-SCRIPT]

; For example,

(DEFPROP STORE (SHOPPING (STORE ?OBJECT)) ASSOCIATED-SCRIPT)

; says that SHOPPING is the associated script for STORE.  When McSAM
; processes (STORE (OBJECT STORE1)), (SHOPPING (STORE ?OBJECT))
; says that the STORE role of the SHOPPING script is to be filled by
; the OBJECT slot of the STORE form.


;****************************************************************
;	PROGRAM
;****************************************************************

; (SPECIAL *CURRENT-SCRIPT* *POSSIBLE-NEXT-EVENTS* *DATA-BASE*)
; This is presently not supported on this implementation.

; *DATA-BASE* is the pointer to the data base.
; *CURRENT-SCRIPT* is the script currently active.  It is a statement
; with the script name as the predicate and the script variables and
; their bindings as the arguments.
; *POSSIBLE-NEXT-EVENTS* is a list of the events in *CURRENT-SCRIPT*
; that have not been seen yet.

; CLEAR-SCRIPTS resets these global variables to NIL

(DE CLEAR-SCRIPTS ()
   (SETQ *DATA-BASE* NIL)
   (SETQ *CURRENT-SCRIPT* NIL)
   (SETQ *POSSIBLE-NEXT-EVENTS* NIL]

; PROCESS-LINE takes one line of the story at a time.  Each line is
; a list of statements (STM).  Either a statement is in the data base
; or it fits into the currently active script or it suggests a new script.

(DE PROCESS-LINE (STORY-LINE)
   (LOOP
      [INITIAL STM NIL]
      [WHILE (SETQ STM (POP STORY-LINE]
      [DO
         (MSG T "Processing " STM)
         (OR
            (FETCH STM)
            (INTEGRATE-INTO-SCRIPT STM)
            (SUGGEST-NEW-SCRIPT STM]
]

; The data base is simply a list of the statements we wish remembered.

; New items are added to the end of the list.

(DE FETCH (STM) (COND ((MEMBER STM *DATA-BASE*) STM]

(DE ADD-STM (STM)
   [OR
      (FETCH STM)
      (SETQ *DATA-BASE* (APPEND1 *DATA-BASE* STM))
   ]
   STM]

; To integrate an incoming statement into the currently active script,
; find the first event in *POSSIBLE-NEXT-EVENTS* that matches the
; statement.  If one is found, update the data base.

(DE INTEGRATE-INTO-SCRIPT (STORY-STM)
   (LOOP
      [INITIAL
         BINDING-FORM NIL
         EVENT NIL
         EVENTS *POSSIBLE-NEXT-EVENTS*
      ]
      [WHILE (SETQ EVENT (POP EVENTS]
      [DO
         (COND 
            ((SETQ BINDING-FORM (MATCH EVENT STORY-STM *CURRENT-SCRIPT*))
               (SETQ *CURRENT-SCRIPT* BINDING-FORM)
               (MSG T "Matches " EVENT)
               (ADD-SCRIPT-INFO EVENT)
      ]
      [UNTIL BINDING-FORM]
      [RESULT BINDING-FORM]
]

; ADD-SCRIPT-INFO is given an event in a script (the one that matched
; the input in INTEGRATE-INTO-SCRIPT).  Each script event up through
; POSITION is instantiated and added to the data base.

(DE ADD-SCRIPT-INFO (POSITION)
   (LOOP
      [INITIAL
         EVENT NIL
         EVENTS *POSSIBLE-NEXT-EVENTS*
      ]
      [WHILE (SETQ EVENT (POP EVENTS]
      [DO (ADD-STM (INSTANTIATE EVENT *CURRENT-SCRIPT*]
      [UNTIL (EQUAL EVENT POSITION]
      [RESULT (SETQ *POSSIBLE-NEXT-EVENTS* EVENTS]
]

; SUGGGEST-NEW-SCRIPT takes a CD form, adds it to the data base, and
; checks the predicate of the form to see if it is linked to a script
; -- e.g., STORE is linked to the SHOPPING script.  If there was a 
; previous script, add it to the data base before switching.
; Note that any events that were left in *POSSIBLE-NEXT-EVENTS*
; are not instantiated.

(DE SUGGEST-NEW-SCRIPT (STORY-STM)
   (ADD-STM STORY-STM)
   (LET (POSSIBILITY (ASSOCIATED-SCRIPT:PREDICATE (PREDICATE:STM STORY-STM)))
      (COND
         (POSSIBILITY
            (AND *CURRENT-SCRIPT* (ADD-STM *CURRENT-SCRIPT*))
            (MSG T "New script")
            (SETQ *CURRENT-SCRIPT* (INSTANTIATE POSSIBILITY STORY-STM))
            (SETQ *POSSIBLE-NEXT-EVENTS*
               (EVENTS:SCRIPT (PREDICATE:STM *CURRENT-SCRIPT*))
]

; INSTANTIATE replaces all the variables in a CD pattern with their
; values -- the function GET-BINDING gets the value of a variable
; from the free variable *BINDING-FORM*

; (SPECIAL *BINDING-FORM*)
; This is presently not supported on this implementation.

(DE INSTANTIATE (PAT *BINDING-FORM*)
   (LET (STM (REMOVE-VARIABLES PAT 'GET-BINDING))
      (MSG T "Instantiating " STM)
      STM
]

(DE GET-BINDING (VAR) (BINDING VAR *BINDING-FORM*]

; REMOVE-VARIABLES takes a CD form like
;	(act (ACTOR var1) (OBJECT var2) ...)
; where each vari has the form (*VAR* atom), plus a function that
; gets the binding of variables.  It returns the CD with all the
; variables replaced by their bindings:
; -- If the variable is bound to NIL then the role is omitted
; -- If it is bound to a token, then the token replaces the 
;	(*VAR* atom)
; -- If it is bound to a CD, then the CD with its variables removed
;	replaces the (*VAR* atom)

(DE REMOVE-VARIABLES (CD-FORM GET-VAL-FN)
   (COND
      ((ATOM CD-FORM) CD-FORM)
      ( T
         (LOOP
            [INITIAL
               ROLE NIL
               FILLER NIL
               RESULT NIL
               ROLES (ARGUMENTS:STM CD-FORM)
            ]
            [WHILE (SETQ ROLE (POP ROLES]
            [DO
               (COND
                  ((SETQ FILLER (GET-ROLE-VAL ROLE GET-VAL-FN))
                     (SETQ RESULT
                        (APPEND1 RESULT (LIST (ROLE:PAIR ROLE) FILLER]
            [RESULT (CONS (PREDICATE:STM CD-FORM) RESULT]
]

; GET-ROLE-VAL gets the filler of a role and if it is a variable
; (i.e., (*VAR* atom)) it gets the value of the variable -- then
; REMOVE-VARIABLES is called to get rid of any variables in the
; this value

(DE GET-ROLE-VAL (ROLE GET-VAL-FN)
   (REMOVE-VARIABLES
      (LET (FORM (FILLER:PAIR ROLE))
         (COND
            ((IS-VAR FORM)
               (GET-VAL-FN (NAME:VAR FORM))
            )
            ( T FORM)
         )
      )
      GET-VAL-FN]

;**********************************************************************
;	PATTERN MATCHER
;**********************************************************************

; MATCH takes three (predicate role-pair...) forms:
; 1) a pattern form which may contain variables
; 2) a constant form which has no variables
; 3) a binding form which is used to specify the bindings of the variables
;    in the pattern (if NIL is given for the binding form, (T) is 
;    assumed)

; for example, if
;  pattern = (PTRANS (ACTOR (*VAR* SHOPPER)) (TO (*VAR* STORE)))
;  constant = (PTRANS (ACTOR JACK0) (TO STORE0))
;  binding = (SHOPPING (SHOPPER JACK0) (STORE STORE0))
; then the variables in the pattern are SHOPPER and STORE and the
; binding form says that these variables are bound to JACK0 and STORE0

; The pattern matches the constant if the predicates are equal and if
; all of the roles in the pattern are matched by roles in the constant
; -- a variable matches if its binding matches
; -- roles in the constant that are not in the pattern are ignored

; MATCH returns either NIL if the match failed or an updated binding
; form that includes any new variable bindings that may have been made

; a NIL constant always matches

(DE MATCH (PAT CONST BIND-LIST)
   (LET (BINDING-FORM (OR BIND-LIST (LIST T)))
      (COND
         ((OR (NULL CONST) (EQUAL PAT CONST)) BINDING-FORM)
         ((IS-VAR PAT) (MATCH-VAR PAT CONST BINDING-FORM))
         ((OR (ATOM CONST) (ATOM PAT)) NIL)
         ((EQ (PREDICATE:STM PAT) (PREDICATE:STM CONST))
            (MATCH-ARGS (ARGUMENTS:STM PAT) CONST BINDING-FORM]

; MATCH-ARGS takes a list of role pairs (a role pair has the form
; (role filler), a constant CD form, and a binding form
; it goes through the list of pairs and matches each pair against the
; corresponding role pair in the constant form -- all of these must
; match

(DE MATCH-ARGS (PAT-ARGS CONST BINDING-FORM)
   (LOOP
      [INITIAL
         PAT-ARG NIL
         CONST-VAL NIL
      ]
      [WHILE (SETQ PAT-ARG (POP PAT-ARGS]
      [DO (SETQ CONST-VAL (BINDING (ROLE:PAIR PAT-ARG) CONST]
      [UNTIL
         (NULL
            (SETQ BINDING-FORM
               (MATCH (FILLER:PAIR PAT-ARG) CONST-VAL BINDING-FORM)
      ]
      [RESULT BINDING-FORM]
]

; MATCH-VAR takes a variable, a constant, and a binding form
; -- if the variable has a binding then the binding must match th
; constant -- otherwise the binding form is updated to bind the
; variable to the constant

(DE MATCH-VAR (PAT CONST BINDING-FORM)
   (LET (VAR-VALUE (BINDING (NAME:VAR PAT) BINDING-FORM))
      (COND
         (VAR-VALUE (MATCH VAR-VALUE CONST BINDING-FORM))
         ( T (APPEND1 BINDING-FORM (LIST (NAME:VAR PAT) CONST]

; a variable binding is found by looking for the variable name in
; a list of role pairs and returning the filler if a pair is found
; with that name as a role

(DE BINDING (VAR-NAME BINDING-FORM)
   (LET [PAIR (ASSOC VAR-NAME (ARGUMENTS:STM BINDING-FORM]
      (COND (PAIR (FILLER:PAIR PAIR]

; clear the data base

(CLEAR-SCRIPTS)