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




トップページに戻る