home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / m / mcsam.zip / MCSAM.SCM next >
Text File  |  1993-01-18  |  13KB  |  398 lines
  1. ; MICRO SAM - Chez Scheme 3.9
  2. ;
  3. ; Micro version of the script applier SAM [Cullingford, 78].  A direct 
  4. ; translation of the version in Inside Computer Understanding [Schank 
  5. ; and Riesbeck, 81].  To try it, use (process-story kite-story).
  6. ;***********************************************************************
  7.  
  8. ; Globals -
  9. ;  *data-base*, the pointer to the data base, which simply a list of
  10. ;     events.
  11. ;  *current-script*, the script currently active.  It is a statement
  12. ;     with the script name as the predicate, and the script variables and
  13. ;     their bindings as the arguments.
  14. ;  *possible-next-events*, a list of the events in *current-script*
  15. ;     that have not been seen yet.
  16.  
  17. ; PROCESS-STORY
  18. ;---------------------------------------------------------------------------
  19. ; PROCESS-STORY takes a list of CDs and hands each one to PROCESS-CD, 
  20. ; which is the main function.  At the end of the story, the current
  21. ; script is added to the date base and the data base is printed.
  22. ;
  23. (define process-story 
  24.    (lambda (story)
  25.       (clear-scripts)
  26.       (process-story* story)
  27.       (printf "~%Story done--- final script header ~%  ")
  28.       (pretty-print *current-script*)
  29.       (add-cd *current-script*)
  30.       (printf "~%Database contains: ~%")
  31.       (pretty-print *data-base*)))
  32.  
  33. (define process-story*
  34.    (lambda (story)
  35.       (cond
  36.          [(null? story) '()]
  37.          [else
  38.            (let ([cd (car story)])
  39.              (printf "~%Input is:~%  ")
  40.              (pretty-print cd)
  41.              (process-cd cd)
  42.              (process-story* (cdr story)))])))
  43.  
  44.  
  45. ; PROCESS-CD
  46. ;---------------------------------------------------------------------------
  47. ; PROCESS-CD takes one CD of the story at a time.  Either a statement
  48. ; is predicted by the current script or it is in the data base or it
  49. ; suggests a new script.
  50. ;
  51. (define process-cd 
  52.    (lambda (cd)
  53.       (or
  54.         (integrate-cd-into-script cd)
  55.         (suggest-new-script cd)
  56.         (begin 
  57.           (printf "~%Adding unlinked event ~%  ")
  58.           (pretty-print cd)
  59.           (printf "~%to data base~%")
  60.           (add-cd cd)))))
  61.  
  62.  
  63.  
  64. ; CLEAR-SCRIPTS
  65. ;---------------------------------------------------------------------------
  66. ; CLEAR-SCRIPTS resets the following globals:
  67.  
  68. ;  *data-base*, the pointer to the data base, which simply a list of
  69. ;     events.
  70. ;  *current-script*, the script currently active.  It is a statement
  71. ;     with the script name as the predicate, and the script variables and
  72. ;     their bindings as the arguments.
  73. ;  *possible-next-events*, a list of the events in *current-script*
  74. ;     that have not been seen yet.
  75. ;
  76. (define clear-scripts
  77.    (lambda ()
  78.       (set! *data-base* '())
  79.       (set! *current-script* '())
  80.       (set! *possible-next-events* '())))
  81.  
  82. (define add-cd
  83.    (lambda (cd)
  84.       (set! *data-base* (append *data-base* (list cd)))
  85.       cd))
  86.  
  87.  
  88. ; INTEGRATE-CD-INTO-SCRIPT
  89. ;---------------------------------------------------------------------------
  90. ; INTEGRATE-CD-INTO-SCRIPT looks for the first event in 
  91. ; *possible-next-events* that matches the statement.  If none is found,
  92. ; it updates the data base.
  93. ;
  94. (define integrate-cd-into-script
  95.    (lambda (cd)
  96.       (integrate-cd-into-script* cd *possible-next-events*)))
  97.  
  98. (define integrate-cd-into-script*
  99.    (lambda (cd events)
  100.       (if (null? events)
  101.       #f
  102.           (let* ([event (car events)]
  103.                  [new-bindings (match event cd *current-script*)])
  104.              (if (null? new-bindings)
  105.                  (integrate-cd-into-script* cd (cdr events))
  106.                  (begin 
  107.                     (set! *current-script* new-bindings)
  108.                     (printf "~%Matches~%")
  109.                     (pretty-print event)
  110.                     (printf "~%")
  111.                     (add-script-info event)
  112.                     #t))))))
  113.  
  114.  
  115. ; ADD-SCRIPT-INFO
  116. ;---------------------------------------------------------------------------
  117. ; ADD-SCRIPT-INFO is given an event in a script (the one that matched
  118. ; the input in INTEGRATE-CD-INTO-SCRIPT).  Each script event up through
  119. ; _position_ is instantiated and added to the data base.
  120. ;
  121. (define add-script-info
  122.    (lambda (position)
  123.       (cond
  124.          [(null? *possible-next-events*) '()]
  125.          [else
  126.           (let* ([event (car *possible-next-events*)]
  127.                  [new-event (instantiate event *current-script*)])
  128.             (set! *possible-next-events* (cdr *possible-next-events*))
  129.             (printf "~%Adding script CD~%  ")
  130.             (pretty-print new-event)
  131.             (printf "~%")
  132.             (add-cd new-event)
  133.             (if (not (equal? position event))
  134.                 (add-script-info position)
  135.                 '()))])))
  136.  
  137.  
  138. ; SUGGEST-NEW-SCRIPT
  139. ;---------------------------------------------------------------------------
  140. ; SUGGEST-NEW-SCRIPT takes a CD form, adds it to the data base, and checks
  141. ; the predicates of the form and its subforms until a link to a script is
  142. ; found (if any).  Thus in (PTRANS (ACTOR (PERSON)) (OBJECT (PERSON))
  143. ; (TO (STORE))) the first script found is under STORE.
  144. ; If there was a previous script, add it to the data base before 
  145. ; switching to another script, but do not instantiate any events that were
  146. ; left in *POSSIBLE-NEXT-EVENTS*.
  147. ;
  148. (define suggest-new-script 
  149.    (lambda (cd)
  150.       (let ([new-script (find-script cd)])
  151.         (cond
  152.            [(null? new-script) '()]
  153.            [else
  154.             (if (not (null? *current-script*)) 
  155.                 (add-cd *current-script*))
  156.             (set! *current-script* (list new-script))
  157.             (set! *possible-next-events* (events:script new-script))
  158.             (integrate-cd-into-script cd)]))))
  159.  
  160.  
  161. ; FIND-SCRIPT
  162. ;---------------------------------------------------------------------------
  163. ; FIND-SCRIPT retrieves a script associated with the given CD form.
  164. ;
  165. (define find-script
  166.    (lambda (cd)
  167.       (cond
  168.         [(atom? cd)
  169.          (associated-script cd)]
  170.         [(not (null? (associated-script (header:cd cd))))
  171.          (associated-script (header:cd cd))]
  172.         [else
  173.          (find-script-from-roles (roles:cd cd))])))
  174.  
  175.  
  176. (define find-script-from-roles
  177.    (lambda (role-pairs)
  178.       (cond
  179.          [(null? role-pairs) '()]
  180.          [else
  181.           (let ([role-script (find-script (filler:pair (car role-pairs)))])
  182.              (if (null? role-script)
  183.                  (find-script-from-roles (cdr role-pairs))
  184.                  role-script))])))
  185.  
  186.  
  187.  
  188.      
  189. ; DATA STRUCTURES AND ACCESS FUNCTIONS
  190. ;--------------------------------------------------------------------------
  191. ; A story is a list of CDs.  A CD is a predicate (PTRANS, PERSON, etc.)
  192. ; plus zero or more (role filler) pairs.  Here is a story in CDs:
  193.  
  194. (set! kite-story
  195.    '(;Jack went to the store.
  196.      (PTRANS (ACTOR (PERSON (NAME JACK)))
  197.              (OBJECT (PERSON (NAME JACK)))
  198.              (TO (STORE)))
  199.      ;He got a kite.
  200.      (ATRANS (OBJECT (KITE))
  201.              (TO (PERSON)))
  202.      ;He went home.
  203.      (PTRANS (ACTOR (PERSON)) 
  204.              (OBJECT (PERSON))
  205.              (TO (HOUSE)))))
  206.  
  207.  
  208. ; CDs are lists with a header and pairs of (role-name filler).
  209.  
  210. (define header:cd
  211.    (lambda (cd) (car cd)))
  212.  
  213. (define roles:cd
  214.    (lambda (cd) (cdr cd)))
  215.  
  216. (define filler:pair
  217.    (lambda (role-pair) (cadr role-pair)))
  218.  
  219. (define (role:pair role-pair)
  220.    (car role-pair))
  221.  
  222. (define (filler:role role cd)
  223.    (let ([assoc-pair (assoc role (roles:cd cd))])
  224.       (if assoc-pair
  225.           (cadr assoc-pair)
  226.           '())))
  227.  
  228.  
  229. ; Variables have the form (*var* name)
  230.  
  231. (define (is-var? x)
  232.    (and (pair? x) (eq? (car x) '*var*)))
  233.  
  234. (define (name:var x)
  235.    (cadr x))
  236.  
  237. ; Scripts are lists of the form (script-name event-list).
  238.  
  239. (define events:script
  240.    (lambda (script)
  241.      (cadr (assoc script *scripts*))))
  242.  
  243. (set! *scripts*
  244.       '((shopping
  245.           ((PTRANS (ACTOR (*var* SHOPPER))
  246.                    (OBJECT (*var* SHOPPER))
  247.                    (TO (*var* STORE)))
  248.            (PTRANS (ACTOR (*var* SHOPPER))
  249.                    (OBJECT (*var* BOUGHT))
  250.                    (TO (*var* SHOPPER)))
  251.            (ATRANS (ACTOR (*var* STORE))
  252.                    (OBJECT (*var* BOUGHT))
  253.                    (FROM (*var* STORE))
  254.                    (TO (*var* SHOPPER)))
  255.            (ATRANS (ACTOR (*var* SHOPPER))
  256.                    (OBJECT (MONEY)) 
  257.                    (FROM (*var* SHOPPER))
  258.                    (TO (*var* STORE)))
  259.            (PTRANS (ACTOR (*var* SHOPPER))
  260.                    (OBJECT (*var* SHOPPER))
  261.                    (FROM (*var* STORE))
  262.                    (TO (*var* ELSEWHERE)))))))
  263.  
  264. ; Some predictates have associated scripts.  For example, the SHOPPING
  265. ; script is associated with STORE.  
  266.  
  267. (set! script-assns '((store shopping)))
  268.  
  269. (define (associated-script predicate)
  270.    (let ([assoc-pair (assoc predicate script-assns)])
  271.       (if assoc-pair
  272.           (cadr assoc-pair)
  273.           '())))
  274.  
  275.  
  276. ; Initialize the data base
  277.                        
  278. (clear-scripts)      
  279.  
  280.  
  281. ; PATTERN MATCHER
  282. ;---------------------------------------------------------------------------
  283.  
  284. ; MATCH takes three (predicate role-pair) forms as arguments:
  285. ; 1. a CD pattern which may contain variables
  286. ; 2. a CD constant which has no variables
  287. ; 3. a binding form which specifies any bindings that the variables in the 
  288. ;    pattern already have.  The predicate of the binding form doesn't matter,
  289. ;    so T is used.
  290. ;    For convenience, MATCH also takes '() as a binding form and converts
  291. ;    it to (T), which is a binding form with no variables bound. 
  292. ; MATCH returns NIL only if the match failed.  A match that succeeds but
  293. ; which involved no variables returns '(T).
  294. ; 
  295. ; For example, if the arguments were
  296. ;  pattern = (PTRANS (ACTOR (*VAR* SHOPPER)) (TO (*VAR* STORE))
  297. ;  constant = (PTRANS (ACTOR (PERSON)) (TO (STORE)))
  298. ;  binding = ((SHOPPER (PERSON) (STORE (STORE))))
  299. ; then the variables in the pattern are SHOPPER and STORE, and the 
  300. ; binding form says that these are bound to PERSON and STORE.
  301. ; The pattern matches the constant if the predicates are equal and if
  302. ; all the roles in the pattern are matched by roles in the constant.
  303. ; A variable matches if its binding matches; roles in the constant that
  304. ; are not in the pattern are ignored.
  305.  
  306. ; MATCH returns either NIL if the match failed, or an updated binding
  307. ; form that includes any new bindings made.
  308.  
  309. ; A NIL constant always matches.  This means that the constant 
  310. ; (PERSON (NAME (JACK))) matches (PERSON), even though the NAME is
  311. ; missing.
  312.  
  313. (define match
  314.    (lambda (pat const bindings)
  315.       (let ([binding-form
  316.                (if (null? bindings)
  317.                    (list #t)
  318.                    bindings)])
  319.         (cond
  320.            [(or (null? const)
  321.                 (equal? pat const))
  322.             binding-form]
  323.            [(is-var? pat)
  324.             (match-var pat const binding-form)]
  325.            [(or (atom? const)
  326.                 (atom? pat))
  327.             '()]
  328.            [(equal? (header:cd pat) (header:cd const))
  329.             (match-args (roles:cd pat) const binding-form)]
  330.            [else
  331.             '()]))))
  332.  
  333. ; MATCH-ARGS
  334. ;---------------------------------------------------------------------------
  335. ; MATCH-ARGS takes a list of role pairs (a role pair has the form
  336. ; (role filler), a constant CD form, and a binding form.  It goes
  337. ; through the list of pairs and matches each pair against the 
  338. ; corresponding role pair in the constant form--- all of these must
  339. ; match.
  340.  
  341. (define match-args
  342.    (lambda (pat-args const binding-form)
  343.       (cond
  344.          [(null? pat-args)
  345.           binding-form]
  346.          [else
  347.           (let* ([pat-arg-val (filler:pair (car pat-args))]
  348.                  [const-val (filler:role (role:pair (car pat-args)) const)]
  349.                  [binding-form (match pat-arg-val
  350.                                       const-val
  351.                                       binding-form)])
  352.              (if (null? binding-form)
  353.                  '()
  354.                  (match-args (cdr pat-args) const binding-form)))])))
  355.  
  356.  
  357. ; MATCH-VAR
  358. ;---------------------------------------------------------------------------
  359. ; MATCH-VAR takes a variable, a constant, and a binding form.  If the
  360. ; variable has a binding then the binding must match the constant---
  361. ; otherwise the binding form is updated to bind the variable to the
  362. ; constant.
  363.  
  364. (define match-var 
  365.    (lambda (pat const binding-form)
  366.       (let ([var-value (filler:role (name:var pat) binding-form)])
  367.         (cond
  368.            [(not (null? var-value))
  369.             (match var-value const binding-form)]
  370.            [else
  371.             (append binding-form (list (list (name:var pat) const)))]))))
  372.                        
  373.          
  374.  
  375. ; INSTANTIATE
  376. ;---------------------------------------------------------------------------
  377. (define instantiate 
  378.    (lambda (cd-form bindings)
  379.       (cond
  380.          [(atom? cd-form)
  381.           cd-form]
  382.          [(is-var? cd-form)
  383.           (instantiate (filler:role (name:var cd-form) bindings)
  384.                        bindings)]
  385.          [else
  386.           (cons (header:cd cd-form)
  387.                 (accumulate-role-instantiations (roles:cd cd-form) bindings))])))
  388.  
  389. (define accumulate-role-instantiations 
  390.    (lambda (role-pairs bindings)
  391.       (cond
  392.          [(null? role-pairs) '()]
  393.          [else
  394.            (cons (list (role:pair (car role-pairs)) 
  395.                        (instantiate (filler:pair (car role-pairs)) bindings))
  396.                  (accumulate-role-instantiations (cdr role-pairs) bindings))])))
  397.                    
  398.