LispによるProlog処理系の記述例 ;;; ;;; 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