ＬｉｓｐによるＰｒｏｌｏｇ
処理系の記述例
;;;
;;; c:\\program files\\acl62\\prolog.cl
;;;

(defun mb (v d) (list v d)) 


(defun ab (pve d bs) 
　　(if (eq '?_ pve) 
　　　　bs 
　　　　(cons (mb pve d) bs))) 


(defun fb (pve b) (unless (eq '?_ pve) (assoc pve b))) 


(defun ek (b) (first b)) 


(defun ev (b) (second b)) 


(defun v-p (e) (and (symbolp e) 
                    (eql (char (symbol-name e) 0) #\?))) 


(defun e-p (p d) (and (atom p) (atom d) 
                      (not (v-p p)) (not (v-p d)))) 


(defun r-p (p d) (and (listp p) (listp d))) 


(defun u-as (p1 p2 bs) (if (eql p1 p2) bs 'fail)) 


(defun u-ps (p1 p2 bs) 
　　(let ((r (unify (first p1) (first p2) bs))) 
　　　(if (eq 'fail r) 
　　　　　'fail 
　　　　　(unify (rest p1) (rest p2) r)))) 


(defun u-v (p1 p2 bs) 
　　(let ((b (fb p1 bs))) 
　　　(if b 
　　　　　(unify (ev b) p2 bs) 
　　　　　(if (insidep p1 p2 bs) 
　　　　　　'fail 
　　　　　　(ab p1 p2 bs))))) 


(defun insidep (v e bs) 
    (if (equal v e) 
        nil 
        (inside-or-equal-p v e bs))) 


(defun inside-or-equal-p (v e bs) 
　　(cond ((equal v e) t) 
　　　　　　((and (atom e) (not (v-p e))) nil) 
　　　　　　((v-p e) 
　　　　　　　(let ((b (fb e bs))) 
　　　　　　　　(when b (inside-or-equal-p v (eb b) bs))))
　　　　　　(t (or (inside-or-equal-p v (first e) bs) 
                   (inside-or-equal-p v (rest e) bs))))) 


(defun unify (p1 p2 &optional bs) 
　　(cond ((e-p p1 p2) (u-as p1 p2 bs)) 
　　　　　　((v-p p1) (u-v p1 p2 bs)) 
　　　　　　((v-p p2) (u-v p2 p1 bs)) 
　　　　　　((r-p p1 p2) (u-ps p1 p2 bs)) 
　　　　　　(t 'fail))) 


(setf *rs* nil *al* nil) 


(defmacro :- (c &optional a) 
　　`(length (push (list (car ',c) 
                         (cons (cdr ',c) ',a)) 
                   *rs*))) 


(defun get-r (r) 
　　(do ((l *rs* (cdr l)) 
　　　　　(w)) 
　　　　　((null l) (reverse w)) 
　　　(if (eql r (first (car l))) 
          (push (car (rest (car l))) w)))) 


;;;(get-r 'c) ;;; 


(defun vs-in (e) 
　　(if (atom e) 
　　　　(if (v-p e) 
            (list e)) 
            (union (vs-in (car e)) (vs-in (cdr e))))) 


(defun c-vs1 (r) 
    (setf *al* (mapcar #'(lambda (v) 
                         (list v (gensym "?")))
                         (vs-in r)))) 


(defun c-vs2 (r) 
　　(cond ((null r) nil) 
　　　　　　((and (atom r) (v-p r)) 
             (second (assoc r (reverse *al*))))
　　　　　　((atom r) r) 
　　　　　　(t (cons (c-vs2 (car r)) 
                     (c-vs2 (cdr r)))))) 


(defun c-vs3 (r) (c-vs1 r) (c-vs2 r)) 


(defun ps (p as bs) 
　　(mapcan #'(lambda (r) 
                (let ((re (unify as (car r) bs))) 
　　　　　(when (not (eql re 'fail)) 
　　　　　　　　(if (not (null (cdr r))) 
                    (pr (cdr r) re) (list re)))))
              　　　　　(mapcar #'c-vs3 (get-r p)))) 


(defun pr (expr &optional binds) 
　　(case (car expr) 
　　　　(and (p-and (reverse (cdr expr)) binds)) 
　　　　(or (p-or (cdr expr) binds)) 
　　　　(not (p-not (cadr expr) binds)) 
　　　　(t (ps (car expr) (cdr expr) binds)))) 


(defun p-and (clauses binds) 
　　(if (null clauses) 
　　　　　(list binds) 
　　　(mapcan #'(lambda (b) 
                  (pr (car clauses) b)) 
                      (p-and (cdr clauses)
                binds)))) 


(defun p-or (clauses binds) 
    (mapcan #'(lambda (c) (pr c binds)) clauses))



(defun p-not (clause binds) 
    (unless (pr clause binds) (list binds))) 


(defun i-v (v l) 
　　(let* ((a1 (assoc v l)) 
           (a2 (assoc (second a1) l)) 
           (a3 (second a2)))
  　　　(if a3 (format t "~%~a <----- ~a" v a3)))) 


(defun i-vs (l) 
　　(do ((lst (reverse (vs-in l)) (cddr lst))) 
　　　　　((null lst)) 
　　　(i-v (car lst) l))) 


(defun is-vs (l) 
　　(do ((lst l (cdr lst))) 
　　　　　((null lst)) 
　　　(print '***************************) 
      (i-vs (car lst)))) 


;;; 
;;; (get-answer '(f ?x ?y)) 
;;; (get-answer '(si ?x ?y)) 
;;; 
(defun get-answer (query) 
　　(let ((lst (pr query))) 
　　　(format t "~%***** Your query is ~a." query) 
         (is-vs lst)))


;;; 
;;; 宣言的知識例 
;;; 
(:- (p d n)) 
(:- (p d de)) 
(:- (m d)) 
(:- (f ?x ?y) (and (p ?x ?y) (m ?x))) 
(:- (= ?x ?x)) 
(:- (si ?x ?y) (and (p ?z ?x) (p ?z ?y) 
                    (not (= ?x ?y)))) 
;;; 
;;;***** Your query is (f ?x ?y). 
;;;*************************** 
;;;?x <----- d 
;;;?y <----- de 
;;;*************************** 
;;;?x <----- d 
;;;?y <----- n 
;;;nil 
;;; 
;;;***** Your query is (si ?x ?y). 
;;;*************************** 
;;;?x <----- de 
;;;?y <----- n 
;;;*************************** 
;;;?x <----- n 
;;;?y <----- de 
;;;nil