;***********************************************************************
;
;                           MICRO SAM - Chez Scheme 4.0a
;
; Micro version of the script applier SAM [Cullingford, 78].  A direct 
; translation of the version in Inside Computer Understanding [Schank 
; and Riesbeck, 81].  To try it, use (process-story kite-story).
; 
; Modified for scheme 5.0b by removing an extend-syntax for enque!
;***********************************************************************

; Some help routines
;--------------------------------------------------------------------------
(define snoc
  (lambda (ls x)
    (append ls (list x))))



; PROCESS-STORY
;---------------------------------------------------------------------------
; PROCESS-STORY takes a list of CDs and hands each one to PROCESS-CD, 
; which is the main function.  At the end of the story, the current
; script is added to the date base and the data base is printed.
;
(define process-story 
  (lambda (story)
    (clear-scripts)
    (process-story* story)
    (printf "~nStory done--- final script header ~n  ")
    (pretty-print *current-script*)
    (add-cd *current-script*)
    (printf "~nDatabase contains: ~n")
    (pretty-print *data-base*)))

(define process-story*
  (lambda (story)
    (cond
      [(null? story) '()]
      [else
	(let ([cd (car story)])
	  (printf "~nInput is:~n  ")
	  (pretty-print cd)
	  (process-cd cd)
	  (process-story* (cdr story)))])))


; PROCESS-CD
;---------------------------------------------------------------------------
; PROCESS-CD takes one CD of the story at a time.  Either a statement
; is predicted by the current script or it is in the data base or it
; suggests a new script.
;
(define process-cd 
  (lambda (cd)
    (or
      (integrate-cd-into-script cd)
      (suggest-new-script cd)
      (begin 
	(printf "~nAdding unlinked event ~n  ")
	(pretty-print cd)
	(printf "~nto data base~n")
	(add-cd cd)))))



; CLEAR-SCRIPTS
;---------------------------------------------------------------------------
; CLEAR-SCRIPTS resets the following globals:
;  *data-base*, the pointer to the data base, which simply a list of
;     events.
;  *current-script*, 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*, a list of the events in *current-script*
;     that have not been seen yet.
;

(define clear-scripts
  (lambda ()
    (set! *data-base* '())
    (set! *current-script* '())
    (set! *possible-next-events*  '())))

(define add-cd
  (lambda (cd)
    (set! *data-base* (snoc *data-base* cd))))


; INTEGRATE-CD-INTO-SCRIPT
;---------------------------------------------------------------------------
; INTEGRATE-CD-INTO-SCRIPT looks for the first event in 
; *possible-next-events* that matches the statement.  If none is found,
; it updates the data base.
;
(define integrate-cd-into-script
  (lambda (cd)
    (integrate-cd-into-script* cd *possible-next-events*)))

(define integrate-cd-into-script*
  (lambda (cd events)
    (if (null? events)
	#f
	(let* ([event (car events)]
	       [new-bindings (match event cd *current-script*)])
	  (if (null? new-bindings)
	      (integrate-cd-into-script* cd (cdr events))
	      (begin 
		(set! *current-script* new-bindings)
		(printf "~nMatches~n")
		(pretty-print event)
		(printf "~n")
		(add-script-info event)
		#t))))))


; ADD-SCRIPT-INFO
;---------------------------------------------------------------------------
; ADD-SCRIPT-INFO is given an event in a script (the one that matched
; the input in INTEGRATE-CD-INTO-SCRIPT).  Each script event up through
; _position_ is instantiated and added to the data base.
;
(define add-script-info
  (lambda (position)
    (cond
      [(null? *possible-next-events*) '()]
      [else
       (let* ([event (car *possible-next-events*)]
	      [new-event (instantiate event *current-script*)])
	 (set! *possible-next-events* (cdr *possible-next-events*))
	 (printf "~nAdding script CD~n  ")
	 (pretty-print new-event)
	 (newline)
	 (add-cd new-event)
	 (if (not (equal? position event))
	     (add-script-info position)
	     '()))])))


; SUGGEST-NEW-SCRIPT
;---------------------------------------------------------------------------
; SUGGEST-NEW-SCRIPT takes a CD form, adds it to the data base, and checks
; the predicates of the form and its subforms until a link to a script is
; found (if any).  Thus in (PTRANS (ACTOR (PERSON)) (OBJECT (PERSON))
; (TO (STORE))) the first script found is under STORE.
; If there was a previous script, add it to the data base before 
; switching to another script, but do not instantiate any events that were
; left in *POSSIBLE-NEXT-EVENTS*.
;
(define suggest-new-script 
  (lambda (cd)
    (let ([new-script (find-script cd)])
      (cond
	[(not new-script) #f]
	[else
	 (if (not (null? *current-script*)) 
	     (add-cd *current-script*))
	 (set! *current-script* (list new-script))
	 (set! *possible-next-events* (script->events new-script))
	 (integrate-cd-into-script cd)]))))


; FIND-SCRIPT
;---------------------------------------------------------------------------
; FIND-SCRIPT retrieves a script associated with the given CD form.
;
(define find-script
  (lambda (cd)
    (cond
      [(atom? cd) (associated-script cd)]
      [(associated-script (cd->header cd))
       (associated-script (cd->header cd))]
      [else
       (find-script-from-roles (cd->roles cd))])))


(define find-script-from-roles
  (lambda (role-pairs)
    (cond
      [(null? role-pairs) #f]
      [else
       (let ([role-script (find-script (pair->filler (car role-pairs)))])
	 (if (not role-script)
	     (find-script-from-roles (cdr role-pairs))
	     role-script))])))


 
     
; DATA STRUCTURES AND ACCESS FUNCTIONS
;--------------------------------------------------------------------------
; A story is a list of CDs.  A CD is a predicate (PTRANS, PERSON, etc.)
; plus zero or more (role filler) pairs.  Here is a story in CDs:

(define kite-story
  '(;Jack went to the store.
    (PTRANS (ACTOR (PERSON (NAME JACK)))
	    (OBJECT (PERSON (NAME JACK)))
	    (TO (STORE)))
    ;He got a kite.
    (ATRANS (OBJECT (KITE))
	    (TO (PERSON)))
    ;He went home.
    (PTRANS (ACTOR (PERSON)) 
	    (OBJECT (PERSON))
	    (TO (HOUSE)))))


; CDs are lists with a header and pairs of (role-name filler).

(define cd->header car)
(define cd->roles cdr)
(define pair->filler cadr)
(define pair->role car)

(define role->filler
  (lambda (role cd)
    (let ([pair (assq role (cd->roles cd))])
      (and pair (pair->filler pair)))))

; Variables have the form ?name

(define variable?
  (lambda (x)
    (char=? (string-ref (format "~a" x) 0) #\?)))

; strips off the '?'

(define variable->name   
  (lambda (x)
    (string->symbol
      (list->string (cdr (string->list (format "~a" x)))))))

; Scripts are lists of the form (script-name event-list).

(define script->events
  (lambda (script)
    (cadr (assq script *scripts*))))

(define *scripts*
  '((shopping
     (; Go to the store
      (PTRANS (ACTOR ?SHOPPER)
	      (OBJECT ?SHOPPER)
	      (TO ?STORE))

      ; Pick up items
      (PTRANS (ACTOR ?SHOPPER)
	      (OBJECT ?BOUGHT)
	      (TO ?SHOPPER))

      ; You pay the store
      (ATRANS (ACTOR ?SHOPPER)
	      (OBJECT (MONEY)) 
	      (FROM ?SHOPPER)
	      (TO ?STORE))

      ; Store transfers the items to you
      (ATRANS (ACTOR ?STORE)
	      (OBJECT ?BOUGHT)
	      (FROM ?STORE)
	      (TO ?SHOPPER))

      ; Leave the store
      (PTRANS (ACTOR ?SHOPPER)
	      (OBJECT ?SHOPPER)
	      (FROM ?STORE)
	      (TO ?ELSEWHERE))))))

; Some predictates have associated scripts.  For example, the SHOPPING
; script is associated with STORE.  

(define script-assns '((store . shopping)))

(define associated-script
  (lambda (predicate)
    (let ([assoc-pair (assq predicate script-assns)])
      (and assoc-pair (cdr assoc-pair)))))


; Initialize the data base
                       
(clear-scripts)      


; PATTERN MATCHER
;---------------------------------------------------------------------------

; MATCH takes three (predicate role-pair) forms as arguments:
; 1. a CD pattern which may contain variables
; 2. a CD constant which has no variables
; 3. a binding form which specifies any bindings that the variables in the 
;    pattern already have.  The predicate of the binding form doesn't matter,
;    so T is used.
;    For convenience, MATCH also takes '() as a binding form and converts
;    it to (T), which is a binding form with no variables bound. 
; MATCH returns NIL only if the match failed.  A match that succeeds but
; which involved no variables returns '(T).
; 
; For example, if the arguments were
;  pattern = (PTRANS (ACTOR ?SHOPPER) (TO ?STORE))
;  constant = (PTRANS (ACTOR (PERSON)) (TO (STORE)))
;  binding = ((SHOPPER (PERSON) (STORE (STORE))))
; then the variables in the pattern are SHOPPER and STORE, and the 
; binding form says that these are bound to PERSON and STORE.
; The pattern matches the constant if the predicates are equal and if
; all 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 bindings made.

; A NIL constant always matches.  This means that the constant 
; (PERSON (NAME (JACK))) matches (PERSON), even though the NAME is
; missing.

(define match
  (lambda (pat const bindings)
    (let ([binding-form
	   (if (null? bindings)
	       (list #t)
	       bindings)])
      (cond
	[(or (not const) (equal? pat const)) binding-form]
	[(variable? pat) (match-var pat const binding-form)]
	[(or (atom? const) (atom? pat))	 '()]
	[(equal? (cd->header pat) (cd->header const))
	 (match-args (cd->roles pat) const binding-form)]
	[else '()]))))

; MATCH-ARGS
;---------------------------------------------------------------------------
; 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.

(define match-args
  (lambda (pat-args const binding-form)
    (cond
      [(null? pat-args) binding-form]
      [else
       (let* ([pat-arg-val (pair->filler (car pat-args))]
	      [const-val (role->filler (pair->role (car pat-args)) const)]
	      [binding-form (match pat-arg-val
				   const-val
				   binding-form)])
	 (if (null? binding-form)
	     '()
	     (match-args (cdr pat-args) const binding-form)))])))


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

(define match-var 
  (lambda (pat const binding-form)
    (let ([var-value (role->filler (variable->name pat) binding-form)])
      (cond
	[var-value (match var-value const binding-form)]
	[else
	 (append binding-form
		 (list (list (variable->name pat) const)))]))))
                       
         

; INSTANTIATE
;---------------------------------------------------------------------------
(define instantiate 
  (lambda (cd-form bindings)
    (cond
      [(variable? cd-form)
       (instantiate (role->filler (variable->name cd-form) bindings)
		    bindings)]
      [(atom? cd-form) cd-form]
      [else
       (cons (cd->header cd-form)
	     (accumulate-role-instantiations
	      (cd->roles cd-form) bindings))])))

(define accumulate-role-instantiations 
  (lambda (role-pairs bindings)
    (cond
      [(null? role-pairs) '()]
      [else
       (cons (list (pair->role (car role-pairs)) 
		   (instantiate (pair->filler (car role-pairs)) bindings))
	     (accumulate-role-instantiations (cdr role-pairs) bindings))])))
                   
;===========================================================================