forked from norvig/paip-lisp
-
Notifications
You must be signed in to change notification settings - Fork 0
/
prolog1.lisp
113 lines (93 loc) · 3.65 KB
/
prolog1.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
;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;;; Code from Paradigms of AI Programming
;;;; Copyright (c) 1991 Peter Norvig
;;;; File prolog1.lisp: First version of the prolog interpreter (11.2).
(requires "unify")
;; Clauses are represented as (head . body) cons cells
(defun clause-head (clause) (first clause))
(defun clause-body (clause) (rest clause))
;; Clauses are stored on the predicate's plist
(defun get-clauses (pred) (get pred 'clauses))
(defun predicate (relation) (first relation))
(defvar *db-predicates* nil
"A list of all predicates stored in the database.")
(defmacro <- (&rest clause)
"Add a clause to the data base."
`(add-clause ',clause))
(defun add-clause (clause)
"Add a clause to the data base, indexed by head's predicate."
;; The predicate must be a non-variable symbol.
(let ((pred (predicate (clause-head clause))))
(assert (and (symbolp pred) (not (variable-p pred))))
(pushnew pred *db-predicates*)
(setf (get pred 'clauses)
(nconc (get-clauses pred) (list clause)))
pred))
(defun clear-db ()
"Remove all clauses (for all predicates) from the data base."
(mapc #'clear-predicate *db-predicates*))
(defun clear-predicate (predicate)
"Remove the clauses for a single predicate."
(setf (get predicate 'clauses) nil))
(defun prove (goal bindings)
"Return a list of possible solutions to goal."
(mapcan #'(lambda (clause)
(let ((new-clause (rename-variables clause)))
(prove-all (clause-body new-clause)
(unify goal (clause-head new-clause) bindings))))
(get-clauses (predicate goal))))
(defun prove-all (goals bindings)
"Return a list of solutions to the conjunction of goals."
(cond ((eq bindings fail) fail)
((null goals) (list bindings))
(t (mapcan #'(lambda (goal1-solution)
(prove-all (rest goals) goal1-solution))
(prove (first goals) bindings)))))
(defun rename-variables (x)
"Replace all variables in x with new ones."
(sublis (mapcar #'(lambda (var) (cons var (gensym (string var))))
(variables-in x))
x))
(defun unique-find-anywhere-if (predicate tree
&optional found-so-far)
"Return a list of leaves of tree satisfying predicate,
with duplicates removed."
(if (atom tree)
(if (funcall predicate tree)
(adjoin tree found-so-far)
found-so-far)
(unique-find-anywhere-if
predicate
(first tree)
(unique-find-anywhere-if predicate (rest tree)
found-so-far))))
(defun find-anywhere-if (predicate tree)
"Does predicate apply to any atom in the tree?"
(if (atom tree)
(funcall predicate tree)
(or (find-anywhere-if predicate (first tree))
(find-anywhere-if predicate (rest tree)))))
(defmacro ?- (&rest goals) `(top-level-prove ',goals))
(defun top-level-prove (goals)
"Prove the goals, and print variables readably."
(show-prolog-solutions
(variables-in goals)
(prove-all goals no-bindings)))
(defun show-prolog-solutions (vars solutions)
"Print the variables in each of the solutions."
(if (null solutions)
(format t "~&No.")
(mapc #'(lambda (solution) (show-prolog-vars vars solution))
solutions))
(values))
(defun show-prolog-vars (vars bindings)
"Print each variable with its binding."
(if (null vars)
(format t "~&Yes")
(dolist (var vars)
(format t "~&~a = ~a" var
(subst-bindings bindings var))))
(princ ";"))
(defun variables-in (exp)
"Return a list of all the variables in EXP."
(unique-find-anywhere-if #'variable-p exp))