-
Notifications
You must be signed in to change notification settings - Fork 8
/
funify.lisp
131 lines (116 loc) · 4.22 KB
/
funify.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
;; -*- Mode: Lisp; -*-
;;; Extra pattern-matching facilities for FTRE
;;; Last edited: 1/29/93, KDF
;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University,
;;; and Johan de Kleer, the Xerox Corporation.
;;; All rights reserved.
;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty. The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.
(in-package :COMMON-LISP-USER)
(proclaim '(special *bound-vars*))
(defun quotize (pattern)
(cond ((null pattern) nil)
((variable? pattern) pattern)
((not (listp pattern)) (list 'QUOTE pattern))
((eq (car pattern) :EVAL) (cadr pattern))
(t `(cons ,(quotize (car pattern))
,(quotize (cdr pattern))))))
(defmacro rlet (var-specs &rest body)
;; Provides means for lisp code in body to
;; add information to the rule's environment.
(let ((*bound-vars*
(append (mapcar #'car var-specs) *bound-vars*)))
`(let ,(mapcar
#'(lambda (let-clause)
(list (car let-clause)
(if (and (listp (cadr let-clause))
(eq (car (cadr let-clause))
:EVAL))
(cadr (cadr let-clause))
(quotize (cadr let-clause)))))
var-specs)
,@ (fully-expand-body body))))
;;; Finding free variables in a pattern
(defun pattern-free-variables (pattern)
(pattern-free-vars1 pattern nil))
(defun pattern-free-vars1 (pattern vars)
(cond ((null pattern) vars)
((variable? pattern)
(if (or (member pattern vars)
(member pattern *bound-vars*))
vars
(cons pattern vars)))
((atom pattern) vars)
(t (pattern-free-vars1
(cdr pattern)
(pattern-free-vars1 (car pattern) vars)))))
;;;; Open-coding unification
(defun generate-match-body (pattern vars
var-alist extra-test
&aux structure-tests
equal-tests binding-specs)
(dolist (test (generate-unify-tests pattern vars nil 'P))
(cond ((variable? (car test))
;test looks like (?x (nth p) (nth p) ...)
(setq equal-tests
(append (generate-pairwise-tests (cdr test))
equal-tests))
(if extra-test
(push (cons (car test) (car (last test)))
var-alist))
(push (car (last test)) binding-specs))
(t (push test structure-tests))))
(setq extra-test (sublis var-alist extra-test))
(when (pattern-free-variables extra-test)
(error "Rule test includes free variable: ~A"
extra-test))
(values (append structure-tests equal-tests
(if extra-test (list extra-test)))
binding-specs))
(defun generate-pairwise-tests (tests)
(cond ((or (null tests) (null (cdr tests))) nil)
(t (cons (list 'EQUAL (car tests) (cadr tests))
(generate-pairwise-tests (cdr tests))))))
;;; Generate a list of explicit tests for matching
;;; the given pattern. Assumes that the pattern
;;; to be tested will be in variable "P".
;;; Tests are returned in backward order.
;;; (generate-unify-tests '(foo ?x) nil nil 'P)
;;; returns: '((NULL (CDR (CDR P)))
;;; (EQUAL ?X (CAR (CDR P)))
;;; (CONSP (CDR P))
;;; (EQUAL (QUOTE FOO) (CAR P))
;;; (CONSP P))
(defun generate-unify-tests (pattern vars tests path)
(cond ((null pattern)
;this is the end
(cons `(null ,path) tests))
((member pattern vars)
;; must see if the pattern has been bound elsewhere,
;; and if it has, test to see if the element here is
;; consistent with that earlier binding.
(let ((previous (assoc pattern tests)))
(cond (previous ;add this position to test it
(push path (cdr previous))
tests)
(t (cons (list pattern path) tests)))))
;; if variable, it must be bound so test
;; against the current value.
((variable? pattern) (cons `(equal ,pattern ,path)
tests))
;; if not a list, then see if equal
((numberp pattern)
(cons `(and (numberp ,path) (= ,pattern ,path))
tests))
((atom pattern) (cons `(equal ',pattern ,path) tests))
;; recurse on a list
(t (generate-unify-tests (cdr pattern) vars
(generate-unify-tests (car pattern) vars
;avoid lisp errors
(cons `(consp ,path)
tests)
;extend the path
(list 'car path))
;extend path in other direction
(list 'cdr path)))))