home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 5.ddi / EXPLORER / VIEWER / ATT.D next >
Encoding:
Text File  |  1984-10-21  |  9.0 KB  |  242 lines
  1. ;;;; This file contains sample data for demonstrating a simple
  2. ;;;; transition-tree language-understanding system.
  3.  
  4. ;;; This section contains the top-level interface procedure and
  5. ;;; the reply procedures.
  6.  
  7. (DEFUN INTERFACE ()
  8.   (PRINT '>)
  9.   (DO ((INPUT (READ) (READ)))
  10.       ((NULL INPUT) 'DONE)
  11.     (LET ((ANSWER (QUESTION INPUT)))
  12.       (COND ((OR (NOT ANSWER)                   ;Goof, parse failed.
  13.                  (SECOND ANSWER))               ;Goof, words remain at end.
  14.          (FORMAT T "~%Sorry, I can't parse that."))))
  15.     (PRINT '>)))
  16.  
  17. (DEFUN REPORT-IDENTITY (OBJECTS)
  18.   (COND ((NULL OBJECTS) (FORMAT "~%There are none."))
  19.     ((NULL (CDR OBJECTS))
  20.      (FORMAT T "~%There is just ~A." OBJECTS))
  21.     (T (FORMAT T "~%They Are ~A." OBJECTS))))
  22.  
  23. (DEFUN REPORT-NUMBER (OBJECTS)
  24.   (COND ((NULL OBJECTS) (FORMAT T "~%There are none."))
  25.     ((NULL (CDR OBJECTS)) (FORMAT T "~%There is only 1."))
  26.     (T (FORMAT T "~%There are ~A." (LENGTH OBJECTS)))))
  27.  
  28. (DEFUN REPORT-ATTRIBUTES (ATTRIBUTES TOOLS)
  29.   (MAPCAR #'(LAMBDA (TOOL)
  30.                (MAPCAR '(LAMBDA (ATTRIBUTE)
  31.                 (IF (GET TOOL ATTRIBUTE)
  32.                     (FORMAT T "~%~A's ~A is ~A."
  33.              TOOL ATTRIBUTE (GET TOOL ATTRIBUTE))
  34.                     (FORMAT T "~%~A's ~A is unknown."
  35.              TOOL ATTRIBUTE)))
  36.                 ATTRIBUTES))
  37.           TOOLS))
  38.  
  39. (DEFUN REPORT-DISTANCE (X Y)
  40.   (COND ((NULL X) (FORMAT T "~%Sorry, I couldn't find the first tool."))
  41.     ((NULL Y) (FORMAT T "~%Sorry, I couldn't find the second tool."))
  42.     (T (FORMAT T "~%The distance is the square root of ~A."
  43.         (+ (SQUARE (- (GET X 'X-COORDINATE)
  44.             (GET Y 'X-COORDINATE)))
  45.          (SQUARE (- (GET X 'Y-COORDINATE)
  46.               (GET Y 'Y-COORDINATE)))
  47.          (SQUARE (- (GET X 'Z-COORDINATE)
  48.               (GET Y 'Z-COORDINATE))))))))
  49.  
  50. (DEFUN SQUARE (X) (* X X))
  51.  
  52. (DEFUN MAKE-SEARCH-PROCEDURE (PROPERTIES TOOL)
  53.   `(LET ((CANDIDATES (GET ',(OR (GET TOOL 'SINGULAR-FORM) TOOL)
  54.                           'INSTANCE)))
  55.      ,@(MAPCAR #'(LAMBDA (FILTER)
  56.                    `(SETQ CANDIDATES (REMOVE-IF-NOT ',FILTER CANDIDATES)))
  57.                (MAPCAR #'(LAMBDA (PROPERTY) (GET PROPERTY 'TEST-PROCEDURE))
  58.                        PROPERTIES))
  59.      CANDIDATES))
  60.  
  61. ;;; This section contains the grammar's transition trees.
  62.  
  63. (RECORD QUESTION
  64.         ((BRANCH ((PARSE PRESENT)
  65.                   (BRANCH (THE (PARSE ATTRIBUTES) OF (PARSE TOOLS)
  66.                            (PARSE-RESULT-IF-END
  67.                             (REPORT-ATTRIBUTES ATTRIBUTES TOOLS)))
  68.                           ((PARSE TOOLS) S (PARSE ATTRIBUTES)
  69.                            (PARSE-RESULT-IF-END
  70.                             (REPORT-ATTRIBUTES ATTRIBUTES TOOLS)))))
  71.                  (HOW MANY METERS IS (PARSE TOOL1) FROM (PARSE TOOL2)
  72.                   (PARSE-RESULT-IF-END
  73.                    (REPORT-DISTANCE TOOL1 TOOL2)))
  74.                  (IDENTIFY (PARSE TOOLS)
  75.                            (PARSE-RESULT-IF-END
  76.                                  (REPORT-IDENTITY TOOLS)))
  77.                  (COUNT (PARSE TOOLS)
  78.                         (PARSE-RESULT-IF-END
  79.                               (REPORT-NUMBER TOOLS))))))
  80.  
  81. (RECORD PRESENT
  82.         ((BRANCH (SHOW ME (PARSE-RESULT 'PRINT))
  83.                  (WHAT IS (PARSE-RESULT 'PRINT))
  84.                  (WHAT ARE (PARSE-RESULT 'PRINT))
  85.                  (GIVE (PARSE-RESULT 'PRINT))
  86.                  (DISPLAY (PARSE-RESULT 'PRINT))
  87.                  (PRINT (PARSE-RESULT 'PRINT))
  88.                  (PRESENT (PARSE-RESULT 'PRINT)))))
  89.  
  90. (RECORD A-OR-THE
  91.          ((BRANCH (A (PARSE-RESULT 'INDEFINITE))
  92.                   (THE (PARSE-RESULT 'DEFINITE)))))
  93.  
  94. (RECORD ATTRIBUTES
  95.         ((BRANCH ((PARSE ATTRIBUTE)
  96.                   (PARSE ATTRIBUTES)
  97.                   (PARSE-RESULT (CONS ATTRIBUTE ATTRIBUTES)))
  98.                  (AND (PARSE ATTRIBUTE)
  99.                       (PARSE-RESULT (LIST ATTRIBUTE)))
  100.                  ((PARSE ATTRIBUTE)
  101.                   (PARSE-RESULT (LIST ATTRIBUTE))))))
  102.  
  103. (RECORD ATTRIBUTE
  104.         ((BRANCH (WIDTH (PARSE-RESULT 'WIDTH))
  105.                  (BREADTH (PARSE-RESULT 'WIDTH))
  106.                  (DEPTH (PARSE-RESULT 'DEPTH))
  107.                  (HEIGHT (PARSE-RESULT 'HEIGHT))
  108.                  (LENGTH (PARSE-RESULT 'LENGTH))
  109.                  (WEIGHT (PARSE-RESULT 'WEIGHT))
  110.                  (SIZE (PARSE-RESULT 'SIZE))
  111.                  (COLOR (PARSE-RESULT 'COLOR)))))
  112.  
  113. (RECORD PROPERTIES
  114.          ((BRANCH ((PARSE PROPERTY)
  115.                    (PARSE PROPERTIES)
  116.                    (PARSE-RESULT (CONS PROPERTY PROPERTIES)))
  117.                   (AND (PARSE PROPERTY)
  118.                        (PARSE-RESULT (LIST PROPERTY)))
  119.                   ((PARSE PROPERTY)
  120.                    (PARSE-RESULT (LIST PROPERTY))))))
  121.  
  122. (RECORD PROPERTY
  123.          ((BRANCH (LARGE (PARSE-RESULT 'LARGE))
  124.                   (MEDIUM (PARSE-RESULT 'MEDIUM))
  125.                   (SMALL (PARSE-RESULT 'SMALL))
  126.  
  127.                   (BLACK (PARSE-RESULT 'BLACK))
  128.                   (BLUE (PARSE-RESULT 'BLUE))
  129.                   (RED (PARSE-RESULT 'RED))
  130.                   (YELLOW (PARSE-RESULT 'YELLOW))
  131.  
  132.                   (LONG (PARSE-RESULT 'LONG))
  133.                   (SHORT (PARSE-RESULT 'SHORT)))))
  134.  
  135. (RECORD TOOLS
  136.  ((BRANCH
  137.        ((PARSE A-OR-THE)
  138.               (PARSE TOOL-TYPE)
  139.               (PARSE-RESULT
  140.                (EVAL (MAKE-SEARCH-PROCEDURE NIL TOOL-TYPE))))
  141.        ((PARSE A-OR-THE)
  142.               (PARSE PROPERTIES)
  143.               (PARSE TOOL-TYPE)
  144.               (PARSE-RESULT
  145.                (EVAL (MAKE-SEARCH-PROCEDURE PROPERTIES TOOL-TYPE)))))))
  146.  
  147. (RECORD TOOL-TYPE
  148.          ((BRANCH (HAMMERS (PARSE-RESULT 'HAMMERS))
  149.                   (SCREWDRIVERS (PARSE-RESULT 'SCREWDRIVERS))
  150.                   (SAWS (PARSE-RESULT 'SAWS))
  151.                   (WRENCHES (PARSE-RESULT 'WRENCHES))
  152.                   (HAMMER (PARSE-RESULT 'HAMMER))
  153.                   (SCREWDRIVER (PARSE-RESULT 'SCREWDRIVER))
  154.                   (SAW (PARSE-RESULT 'SAW))
  155.                   (WRENCH (PARSE-RESULT 'WRENCH)))))
  156.  
  157. (RECORD TOOL1 ((PARSE TOOLS) (PARSE-RESULT (FIRST TOOLS))))
  158.  
  159. (RECORD TOOL2 ((PARSE TOOLS) (PARSE-RESULT (FIRST TOOLS))))
  160.  
  161. ;;; This section contains definitions for common property
  162. ;;; predicates.
  163.  
  164. (DEFUN LARGEP (OBJECT) (EQUAL (GET OBJECT 'SIZE) 'LARGE))
  165. (DEFUN MEDIUMP (OBJECT) (EQUAL (GET OBJECT 'SIZE) 'MEDIUM))
  166. (DEFUN SMALLP (OBJECT) (EQUAL (GET OBJECT 'SIZE) 'SMALL))
  167.  
  168. (DEFUN BLACKP (OBJECT) (EQUAL (GET OBJECT 'COLOR) 'BLACK))
  169. (DEFUN BLUEP (OBJECT) (EQUAL (GET OBJECT 'COLOR) 'BLUE))
  170. (DEFUN REDP (OBJECT) (EQUAL (GET OBJECT 'COLOR) 'RED))
  171. (DEFUN YELLOWP (OBJECT) (EQUAL (GET OBJECT 'COLOR) 'YELLOW))
  172.  
  173. (DEFUN LONGP (OBJECT) (EQUAL (GET OBJECT 'SIZE) 'LONG))
  174. (DEFUN SHORTP (OBJECT) (EQUAL (GET OBJECT 'SIZE) 'SHORT))
  175.  
  176. ;;; This section contains forms that attach property predicates
  177. ;;; to property names.
  178.  
  179. (SETF (GET 'LARGE 'TEST-PROCEDURE) 'LARGEP)
  180. (SETF (GET 'MEDIUM 'TEST-PROCEDURE) 'MEDIUMP)
  181. (SETF (GET 'SMALL 'TEST-PROCEDURE) 'SMALLP)
  182.  
  183. (SETF (GET 'LONG 'TEST-PROCEDURE) 'LONGP)
  184. (SETF (GET 'SHORT 'TEST-PROCEDURE) 'SHORTP)
  185.  
  186. (SETF (GET 'BLACK 'TEST-PROCEDURE) 'BLACKP)
  187. (SETF (GET 'BLUE 'TEST-PROCEDURE) 'BLUEP)
  188. (SETF (GET 'RED 'TEST-PROCEDURE) 'REDP)
  189. (SETF (GET 'YELLOW 'TEST-PROCEDURE) 'YELLOWP)
  190.  
  191. ;;; This section attaches grammatical properties to the tool
  192. ;;; names.
  193.  
  194. (SETF (GET 'HAMMERS 'SINGULAR-FORM) 'HAMMER)
  195. (SETF (GET 'SCREWDRIVERS 'SINGULAR-FORM) 'SCREWDRIVER)
  196. (SETF (GET 'SAWS 'SINGULAR-FORM) 'SAW)
  197. (SETF (GET 'WRENCHES 'SINGULAR-FORM) 'WRENCH)
  198.  
  199. ;;; This section creates the tools.
  200.  
  201. (SETF (GET 'TOOL 'INSTANCE) '(HAMMER SCREWDRIVER SAW WRENCH))
  202. (SETF (GET 'HAMMER 'INSTANCE) '(HAMMER8))
  203. (SETF (GET 'SCREWDRIVER'INSTANCE) '(S1 S2 S3 S4 S5))
  204. (SETF (GET 'SAW 'INSTANCE) '(SAW3))
  205. (SETF (GET 'WRENCH 'INSTANCE) '(WRENCH1 WRENCH2))
  206.  
  207. (DEFUN MAKE-TOOL (TOOL &OPTIONAL COLOR SIZE LENGTH WEIGHT (X 0) (Y 0) (Z 0))
  208.   (SETF (GET TOOL 'COLOR) COLOR)
  209.   (SETF (GET TOOL 'SIZE) SIZE)
  210.   (SETF (GET TOOL 'LENGTH) LENGTH)
  211.   (SETF (GET TOOL 'WEIGHT) WEIGHT)
  212.   (SETF (GET TOOL 'X-COORDINATE) X)
  213.   (SETF (GET TOOL 'Y-COORDINATE) Y)
  214.   (SETF (GET TOOL 'Z-COORDINATE) Z))
  215.  
  216. (MAKE-TOOL     'SAW3 'RED 'MEDIUM     4 5 0 0 0)
  217. (MAKE-TOOL    'HAMMER8 'BLUE 'MEDIUM     1 8 8 4 3)
  218. (MAKE-TOOL    'WRENCH1 'RED 'SMALL     8 2 8 1 8)
  219. (MAKE-TOOL    'WRENCH2 'RED 'LARGE     2 8 1 7 2)
  220. (MAKE-TOOL    'S1 'BLUE 'LARGE     8 1 7 2 8)
  221. (MAKE-TOOL    'S2 'RED 'LARGE         5 8 3 9 0)
  222. (MAKE-TOOL    'S3 'RED 'SMALL         7 9 7 3 2)
  223. (MAKE-TOOL    'S4 'YELLOW 'SMALL     2 8 1 3 3)
  224. (MAKE-TOOL    'S5 'BLACK 'MEDIUM     3 3 3 3 3)
  225.  
  226. ;;; This section contains some sample sentences.
  227.  
  228. (SETF A '(IDENTIFY THE LARGE SCREWDRIVERS)
  229.       B '(COUNT THE LARGE RED SCREWDRIVERS)
  230.       C '(SHOW ME THE HEIGHT LENGTH AND COLOR OF THE SAW)
  231.       D '(PRINT THE SAW S WEIGHT)
  232.       E '(HOW MANY METERS IS THE SAW FROM THE HAMMER)
  233.       F '(HOW MANY METERS IS THE YELLOW SAW FROM THE BLACK HAMMER)
  234.       G '(SHOW ME THE LENGTH OF THE BLUE SCREWDRIVERS))
  235.  
  236. ;;; This section contains a Common LISP primitive that is not yet
  237. ;;; in GC LISP.
  238.  
  239. (DEFUN REMOVE-IF-NOT (P L)
  240.   (MAPCAN #'(LAMBDA (E) (IF (FUNCALL P E) (LIST E) NIL)) L))
  241.  
  242.