home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 5.ddi / EXPLORER / VIEWER / MATCHING.P < prev    next >
Encoding:
Text File  |  1984-10-14  |  3.3 KB  |  86 lines
  1. ;;;; This file contains the matching program.
  2.  
  3. (DEFUN MATCH (P D ASSIGNMENTS)
  4.   (COND ((AND (NULL P) (NULL D))                        ;Succeed.
  5.          (COND ((NULL ASSIGNMENTS) T)
  6.                (T ASSIGNMENTS)))
  7.         ((OR (NULL P) (NULL D)) NIL)                    ;Fail.
  8.         ((OR (EQUAL (FIRST P) '?)                       ;Match ? pattern.
  9.              (EQUAL (FIRST P) (FIRST D)))               ;Identical elements.
  10.          (MATCH (REST P) (REST D) ASSIGNMENTS))
  11.         ((EQUAL (FIRST P) '+)                           ;Match + pattern.
  12.          (OR (MATCH (REST P) (REST D) ASSIGNMENTS)
  13.              (MATCH P (REST D) ASSIGNMENTS)))
  14.         ((ATOM (FIRST P)) NIL)                          ;Losing atom.
  15.         ((EQUAL (PATTERN-INDICATOR (FIRST P)) '>)       ;Match $>$ variable.
  16.          (MATCH (REST P) (REST D)
  17.                 (SHOVE-GR (PATTERN-VARIABLE (FIRST P))
  18.                           (FIRST D)
  19.                           ASSIGNMENTS)))
  20.         ((EQUAL (PATTERN-INDICATOR (FIRST P)) '<)       ;Substitute variable.
  21.          (MATCH (CONS (PULL-VALUE (PATTERN-VARIABLE (FIRST P)) ASSIGNMENTS)
  22.                       (REST P))
  23.                 D
  24.                 ASSIGNMENTS))
  25.         ((EQUAL (PATTERN-INDICATOR (FIRST P)) '+)       ;Match + variable.
  26.          (LET ((NEW-ASSIGNMENTS (SHOVE-PL (PATTERN-VARIABLE (FIRST P))
  27.                                           (FIRST D)
  28.                                           ASSIGNMENTS)))
  29.            (OR (MATCH (REST P) (REST D) NEW-ASSIGNMENTS)
  30.                (MATCH P (REST D) NEW-ASSIGNMENTS))))
  31.         ((AND (EQUAL (PATTERN-INDICATOR (FIRST P))      ;Match restriction.
  32.                      'RESTRICT)
  33.               (EQUAL (RESTRICTION-INDICATOR (FIRST P)) '?)
  34.               (TEST (RESTRICTION-PREDICATES (FIRST P)) (FIRST D)))
  35.          (MATCH (REST P) (REST D) ASSIGNMENTS))))
  36.  
  37. ;;; This section contains selector procedures.
  38.  
  39. (DEFUN PATTERN-INDICATOR (L)
  40.   (FIRST L))
  41.  
  42. (DEFUN PATTERN-VARIABLE (L)
  43.   (SECOND L))
  44.  
  45. (DEFUN MATCH-VALUE (KEY A-LIST)
  46.   (SECOND (ASSOC KEY A-LIST)))
  47.  
  48. (DEFUN PULL-VALUE (VARIABLE A-LIST)
  49.   (SECOND (ASSOC VARIABLE A-LIST)))
  50.  
  51. ;;; This section contains mutator procedures.
  52.  
  53. (DEFUN SHOVE-GR (VARIABLE ITEM A-LIST)
  54.   (APPEND A-LIST (LIST (LIST VARIABLE ITEM))))
  55.  
  56. (DEFUN SHOVE-PL (VARIABLE ITEM A-LIST)
  57.   (COND ((NULL A-LIST) (LIST (LIST VARIABLE (LIST ITEM))))
  58.         ((EQUAL VARIABLE (FIRST (FIRST A-LIST)))
  59.          (CONS (LIST VARIABLE (APPEND (SECOND (FIRST A-LIST))
  60.                                       (LIST ITEM)))
  61.                (REST A-LIST)))
  62.         (T (CONS (FIRST A-LIST)
  63.                  (SHOVE-PL VARIABLE ITEM (REST A-LIST))))))
  64.  
  65. (DEFUN RESTRICTION-INDICATOR (PATTERN-ITEM) (SECOND PATTERN-ITEM))
  66.  
  67. (DEFUN RESTRICTION-PREDICATES (PATTERN-ITEM) (REST (REST PATTERN-ITEM)))
  68.  
  69. ;;; This is the auxiliary procedure for testing datum elements to
  70. ;;; see if they satisfy the given predicates.
  71.  
  72. (DEFUN TEST (PREDICATES ARGUMENT)
  73.   (COND ((NULL PREDICATES) T)                     ;All tests T?
  74.         ((FUNCALL (FIRST PREDICATES) ARGUMENT)    ;This test T?
  75.          (TEST (REST PREDICATES) ARGUMENT))
  76.         (T NIL)))                                 ;This test NIL?
  77.  
  78. ;;; These are some representative predicates.
  79.  
  80. (DEFUN COLORP (WORD) (MEMBER WORD '(RED WHITE BLUE)))
  81.  
  82. (DEFUN BAD-WORD-P (WORD) (MEMBER WORD '(SHUCKS DARN)))
  83.  
  84.  
  85.  
  86.