Skip to content
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
186 lines (152 sloc) 5.8 KB
;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;;; Code from Paradigms of AI Programming
;;;; Copyright (c) 1991 Peter Norvig
;;;; File prologc1.lisp: Version 1 of the prolog compiler,
;;;; including the destructive unification routines from Chapter 11.
(requires "prolog")
(defconstant unbound "Unbound")
(defstruct var name (binding unbound))
(defun bound-p (var) (not (eq (var-binding var) unbound)))
(defmacro deref (exp)
"Follow pointers for bound variables."
`(progn (loop while (and (var-p ,exp) (bound-p ,exp))
do (setf ,exp (var-binding ,exp)))
(defun unify! (x y)
"Destructively unify two expressions"
(cond ((eql (deref x) (deref y)) t)
((var-p x) (set-binding! x y))
((var-p y) (set-binding! y x))
((and (consp x) (consp y))
(and (unify! (first x) (first y))
(unify! (rest x) (rest y))))
(t nil)))
(defun set-binding! (var value)
"Set var's binding to value. Always succeeds (returns t)."
(setf (var-binding var) value)
(defun print-var (var stream depth)
(if (or (and *print-level*
(>= depth *print-level*))
(var-p (deref var)))
(format stream "?~a" (var-name var))
(write var :stream stream)))
(defvar *trail* (make-array 200 :fill-pointer 0 :adjustable t))
(defun set-binding! (var value)
"Set var's binding to value, after saving the variable
in the trail. Always returns t."
(unless (eq var value)
(vector-push-extend var *trail*)
(setf (var-binding var) value))
(defun undo-bindings! (old-trail)
"Undo all bindings back to a given point in the trail."
(loop until (= (fill-pointer *trail*) old-trail)
do (setf (var-binding (vector-pop *trail*)) unbound)))
(defvar *var-counter* 0)
(defstruct (var (:constructor ? ())
(:print-function print-var))
(name (incf *var-counter*))
(binding unbound))
(defun prolog-compile (symbol &optional
(clauses (get-clauses symbol)))
"Compile a symbol; make a separate function for each arity."
(unless (null clauses)
(let ((arity (relation-arity (clause-head (first clauses)))))
;; Compile the clauses with this arity
symbol arity (clauses-with-arity clauses #'= arity))
;; Compile all the clauses with any other arity
symbol (clauses-with-arity clauses #'/= arity)))))
(defun clauses-with-arity (clauses test arity)
"Return all clauses whose head has given arity."
(find-all arity clauses
:key #'(lambda (clause)
(relation-arity (clause-head clause)))
:test test))
(defun relation-arity (relation)
"The number of arguments to a relation.
Example: (relation-arity '(p a b c)) => 3"
(length (args relation)))
(defun args (x) "The arguments of a relation" (rest x))
(defun compile-predicate (symbol arity clauses)
"Compile all the clauses for a given symbol/arity
into a single LISP function."
(let ((predicate (make-predicate symbol arity))
(parameters (make-parameters arity)))
`(defun ,predicate (,@parameters cont)
.,(mapcar #'(lambda (clause)
(compile-clause parameters clause 'cont))
(defun make-parameters (arity)
"Return the list (?arg1 ?arg2 ... ?arg-arity)"
(loop for i from 1 to arity
collect (new-symbol '?arg i)))
(defun make-predicate (symbol arity)
"Return the symbol: symbol/arity"
(symbol symbol '/ arity))
(defun compile-clause (parms clause cont)
"Transform away the head, and compile the resulting body."
(mapcar #'make-= parms (args (clause-head clause)))
(clause-body clause))
(defun make-= (x y) `(= ,x ,y))
(defun compile-body (body cont)
"Compile the body of a clause."
(if (null body)
`(funcall ,cont)
(let* ((goal (first body))
(macro (prolog-compiler-macro (predicate goal)))
(macro-val (if macro
(funcall macro goal (rest body) cont))))
(if (and macro (not (eq macro-val :pass)))
(make-predicate (predicate goal)
(relation-arity goal))
(mapcar #'(lambda (arg) (compile-arg arg))
(args goal))
(if (null (rest body))
`#'(lambda ()
,(compile-body (rest body) cont))))))))
(defun compile-call (predicate args cont)
"Compile a call to a prolog predicate."
`(,predicate ,@args ,cont))
(defun prolog-compiler-macro (name)
"Fetch the compiler macro for a Prolog predicate."
;; Note NAME is the raw name, not the name/arity
(get name 'prolog-compiler-macro))
(defmacro def-prolog-compiler-macro (name arglist &body body)
"Define a compiler macro for Prolog."
`(setf (get ',name 'prolog-compiler-macro)
#'(lambda ,arglist .,body)))
(def-prolog-compiler-macro = (goal body cont)
(let ((args (args goal)))
(if (/= (length args) 2)
`(if ,(compile-unify (first args) (second args))
,(compile-body body cont)))))
(defun compile-unify (x y)
"Return code that tests if var and term unify."
`(unify! ,(compile-arg x) ,(compile-arg y)))
(defun compile-arg (arg)
"Generate code for an argument to a goal in the body."
(cond ((variable-p arg) arg)
((not (has-variable-p arg)) `',arg)
((proper-listp arg)
`(list .,(mapcar #'compile-arg arg)))
(t `(cons ,(compile-arg (first arg))
,(compile-arg (rest arg))))))
(defun has-variable-p (x)
"Is there a variable anywhere in the expression x?"
(find-if-anywhere #'variable-p x))
(defun proper-listp (x)
"Is x a proper (non-dotted) list?"
(or (null x)
(and (consp x) (proper-listp (rest x)))))
You can’t perform that action at this time.