(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))) ,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) t) (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)) t) (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 (compile-predicate symbol arity (clauses-with-arity clauses #’= arity)) ;; Compile all the clauses with any other arity (prolog-compile 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 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 make-= (x y) `(= ,x ,y)) (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))) (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))))) (defun maybe-add-undo-bindings (compiled-exps) "Undo any bindings that need undoing. If there are any, bind the trail before we start." (if (length=1 compiled-exps) compiled-exps `((let ((old-trail (fill-pointer *trail*))) ,(first compiled-exps) ,@(loop for exp in (rest compiled-exps) collect ’(undo-bindings! old-trail) collect exp))))) (defun bind-unbound-vars (parameters exp) "If there are any variables in exp (besides the parameters) then bind them to new vars." (let ((exp-vars (set-difference (variables-in exp) parameters))) (if exp-vars `(let ,(mapcar #’(lambda (var) `(,var (?))) exp-vars) ,exp) exp))) (defmacro <- (&rest clause) "Add a clause to the data base." `(add-clause ’,(make-anonymous clause))) (defun make-anonymous (exp &optional (anon-vars (anonymous-variables-in exp))) "Replace variables that are only used once with ?." (cond ((consp exp) (reuse-cons (make-anonymous (first exp) anon-vars) (make-anonymous (rest exp) anon-vars) exp)) ((member exp anon-vars) ’?) (t exp))) (defun anonymous-variables-in (tree) "Return a list of all variables that occur only once in tree." (values (anon-vars-in tree nil nil))) (defun anon-vars-in (tree seen-once seen-more) "Walk the data structure TREE, returning a list of variabless seen once, and a list of variables seen more than once." (cond ((consp tree) (multiple-value-bind (new-seen-once new-seen-more) (anon-vars-in (first tree) seen-once seen-more) (anon-vars-in (rest tree) new-seen-once new-seen-more))) ((not (variable-p tree)) (values seen-once seen-more)) ((member tree seen-once) (values (delete tree seen-once) (cons tree seen-more))) ((member tree seen-more) (values seen-once seen-more)) (t (values (cons tree seen-once) seen-more)))) (defun compile-unify (x y bindings) "Return 2 values: code to test if x and y unify, and a new binding list." (cond ;; Unify constants and conses: ; Case ((not (or (has-variable-p x) (has-variable-p y))) ; 1,2 (values (equal x y) bindings)) ((and (consp x) (consp y)) ; 3 (multiple-value-bind (code1 bindings1) (compile-unify (first x) (first y) bindings) (multiple-value-bind (code2 bindings2) (compile-unify (rest x) (rest y) bindings1) (values (compile-if code1 code2) bindings2)))) ;; Here x or y is a variable. Pick the right one: ((variable-p x) (compile-unify-variable x y bindings)) (t (compile-unify-variable y x bindings)))) (defun compile-if (pred then-part) "Compile a Lisp IF form. No else-part allowed." (case pred ((t) then-part) ((nil) nil) (otherwise `(if ,pred ,then-part)))) (defun compile-unify-variable (x y bindings) "X is a variable, and Y may be." (let* ((xb (follow-binding x bindings)) (x1 (if xb (cdr xb) x)) (yb (if (variable-p y) (follow-binding y bindings))) (y1 (if yb (cdr yb) y))) (cond ; Case: ((or (eq x ’?) (eq y ’?)) (values t bindings)) ; 12 ((not (and (equal x x1) (equal y y1))) ; deref (compile-unify x1 y1 bindings)) ((find-anywhere x1 y1) (values nil bindings)) ; 11 ((consp y1) ; 7,10 (values `(unify! ,x1 ,(compile-arg y1 bindings)) (bind-variables-in y1 bindings))) ((not (null xb)) ;; i.e. x is an ?arg variable (if (and (variable-p y1) (null yb)) (values ’t (extend-bindings y1 x1 bindings)) ; 4 (values `(unify! ,x1 ,(compile-arg y1 bindings)) (extend-bindings x1 y1 bindings)))) ; 5,6 ((not (null yb)) (compile-unify-variable y1 x1 bindings)) (t (values ’t (extend-bindings x1 y1 bindings)))))) ; 8,9 (defun bind-variables-in (exp bindings) "Bind all variables in exp to themselves, and add that to bindings (except for variables already bound)." (dolist (var (variables-in exp)) (unless (get-binding var bindings) (setf bindings (extend-bindings var var bindings)))) bindings) (defun follow-binding (var bindings) "Get the ultimate binding of var according to bindings." (let ((b (get-binding var bindings))) (if (eq (car b) (cdr b)) b (or (follow-binding (cdr b) bindings) b)))) (defun compile-arg (arg bindings) "Generate code for an argument to a goal in the body." (cond ((eq arg ’?) ’(?)) ((variable-p arg) (let ((binding (get-binding arg bindings))) (if (and (not (null binding)) (not (eq arg (binding-val binding)))) (compile-arg (binding-val binding) bindings) arg))) ((not (find-if-anywhere #’variable-p arg)) `’,arg) ((proper-listp arg) `(list .,(mapcar #’(lambda (a) (compile-arg a bindings)) arg))) (t `(cons ,(compile-arg (first arg) bindings) ,(compile-arg (rest arg) bindings))))) (defun bind-new-variables (bindings goal) "Extend bindings to include any unbound variables in goal." (let ((variables (remove-if #’(lambda (v) (assoc v bindings)) (variables-in goal)))) (nconc (mapcar #’self-cons variables) bindings))) (defun self-cons (x) (cons x x)) (def-prolog-compiler-macro = (goal body cont bindings) "Compile a goal which is a call to =." (let ((args (args goal))) (if (/= (length args) 2) :pass ;; decline to handle this goal (multiple-value-bind (code1 bindings1) (compile-unify (first args) (second args) bindings) (compile-if code1 (compile-body body cont bindings1)))))) (defun compile-clause (parms clause cont) "Transform away the head, and compile the resulting body." (bind-unbound-vars parms (compile-body (nconc (mapcar #’make-= parms (args (clause-head clause))) (clause-body clause)) cont (mapcar #’self-cons parms)))) ;*** (defvar *uncompiled* nil "Prolog symbols that have not been compiled.") (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*) (pushnew pred *uncompiled*) ;*** (setf (get pred ’clauses) (nconc (get-clauses pred) (list clause))) pred)) (defun top-level-prove (goals) "Prove the list of goals by compiling and calling it." ;; First redefine top-level-query (clear-predicate ’top-level-query) (let ((vars (delete ’? (variables-in goals)))) (add-clause `((top-level-query) ,@goals (show-prolog-vars ,(mapcar #’symbol-name vars) ,vars)))) ;; Now run it (run-prolog ’top-level-query/0 #’ignore) (format t "~&No.") (values)) (defun run-prolog (procedure cont) "Run a 0-ary prolog procedure with a given continuation." ;; First compile anything else that needs it (prolog-compile-symbols) ;; Reset the trail and the new variable counter (setf (fill-pointer *trail*) 0) (setf *var-counter* 0) ;; Finally, call the query (catch ’top-level-prove (funcall procedure cont))) (defun prolog-compile-symbols (&optional (symbols *uncompiled*)) "Compile a list of Prolog symbols. By default, the list is all symbols that need it." (mapc #’prolog-compile symbols) (setf *uncompiled* (set-difference *uncompiled* symbols))) (defun ignore (&rest args) (declare (ignore args)) nil) (defun show-prolog-vars/2 (var-names vars cont) "Display the variables, and prompt the user to see if we should continue. If not, return to the top level." (if (null vars) (format t "~&Yes") (loop for name in var-names for var in vars do (format t "~&~a = ~a" name (deref-exp var)))) (if (continue-p) (funcall cont) (throw ’top-level-prove nil))) (defun deref-exp (exp) "Build something equivalent to EXP with variables dereferenced." (if (atom (deref exp)) exp (reuse-cons (deref-exp (first exp)) (deref-exp (rest exp)) exp))) (defvar *predicate* nil "The Prolog predicate currently being compiled") (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))) (compile (eval `(defun ,*predicate* (,@parameters cont) .,(maybe-add-undo-bindings (mapcar #’(lambda (clause) (compile-clause parameters clause ’cont)) clauses))))))) (defun compile-body (body cont bindings) "Compile the body of a clause." (cond ((null body) `(funcall ,cont)) ((eq (first body) ’!) ;*** `(progn ,(compile-body (rest body) cont bindings) ;*** (return-from ,*predicate* nil))) ;*** (t (let* ((goal (first body)) (macro (prolog-compiler-macro (predicate goal))) (macro-val (if macro (funcall macro goal (rest body) cont bindings)))) (if (and macro (not (eq macro-val :pass))) macro-val `(,(make-predicate (predicate goal) (relation-arity goal)) ,@(mapcar #’(lambda (arg) (compile-arg arg bindings)) (args goal)) ,(if (null (rest body)) cont `#’(lambda () ,(compile-body (rest body) cont (bind-new-variables bindings goal))))))))))