ProLog.LisP


 * File ProLog.LisP: [|ProLog from (11.3)], with interactive backtracking.

code Common.Lisp; code -*-
 * -*- Mode: LisP; Syntax:


 * [|Source Code] from Paradigms of AI Programming


 * Copyright (c) 1991 Peter Norvig

(requires "unify") ; See : Unify.LisP; does not require "prolog1"


 * does not include destructive unification (11.6); see ProLogC.LisP


 * 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))

(defun args (x) "The arguments of a relation" (rest x)) (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 ',(replace-?-vars 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 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 ',(replace-?-vars goals))) (defun prove-all (goals bindings)

"Find a solution to the conjunction of goals."

(cond ((eq bindings fail) fail)

((null goals) bindings)

(t (prove (first goals) bindings (rest goals))))) (defun prove (goal bindings other-goals)

"Return a list of possible solutions to goal."

(let ((clauses (get-clauses (predicate goal))))

(if (listp clauses)

(some


 * 1) '(lambda (clause)

(let ((new-clause (rename-variables clause)))

(prove-all

(append (clause-body new-clause) other-goals)

(unify goal (clause-head new-clause) bindings))))

clauses)


 * The predicate's "clauses" can be an atom:


 * a primitive function to call

(funcall clauses (rest goal) bindings

other-goals)))) (defun top-level-prove (goals)

(prove-all `(,@goals (show-prolog-vars ,@(variables-in goals)))

no-bindings)

(format t "~&No.")

(values)) (defun show-prolog-vars (vars bindings other-goals)

"Print each variable with its binding.

Then ask the user if more solutions are desired."

(if (null vars)

(format t "~&Yes")

(dolist (var vars)

(format t "~&~a = ~a" var

(subst-bindings bindings var))))

(if (continue-p)

fail

(prove-all other-goals bindings))) (setf (get 'show-prolog-vars 'clauses) 'show-prolog-vars) (defun continue-p

"Ask user if we should continue looking for solutions."

(case (read-char)

(#\; t)

(#\. nil)

(#\newline (continue-p))

(otherwise

(format t " Type ; to see more or . to stop")

(continue-p)))) (defun variables-in (exp)

"Return a list of all the variables in EXP."

(unique-find-anywhere-if #'non-anon-variable-p exp)) (defun non-anon-variable-p (x)

(and (variable-p x) (not (eq x '?)))) (defun replace-?-vars (exp)

"Replace any ? within exp with a var of the form ?123."

(cond ((eq exp '?) (gensym "?"))

((atom exp) exp)

(t (reuse-cons (replace-?-vars (first exp))

(replace-?-vars (rest exp))

exp))))