ＬｉｓｐによるＰｒｏｌｏｇ処理系の記述例
;;;
;;; 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

トップページに戻る