; Pattern-Matching
(forbid)
(terpri)(princ "AProlog (c) 1990 Steffen Goebbels")(terpri)
(defun match (prädikat1 prädikat2 &aux nein)
   (setq nein nil)
   (cond ((eq (car (car prädikat1)) 'not)
          ; not entfernen :
          (setq prädikat1 (cons (cdr (car prädikat1)) (cdr prädikat1)))
          (setq nein t)))
   (cond ((eq (car (car prädikat1)) (car (car prädikat2)))
          ;Regeln gehören zur selben Funktion
          (cond ((anpassen 2)
                 (setq prädikat1 (cdr prädikat1))
                 (setq prädikat2 (cdr prädikat2))
                 (cond ((null prädikat2)
                        (cond (nein '(nil)) ;entgültig, da not t = nil
                              (t (cond ((null prädikat1) (VarAusgabe))
                                       (t (main prädikat1))))))
                       (nein (deMorgan prädikat2 prädikat1))
                       (t (main (append prädikat2 prädikat1)))))
                (t nil)))
         (t nil)))

(defun anpassen (pos &aux i j)
  (setq i (nth pos (car prädikat1)))
  (setq j (nth pos (car prädikat2)))
  (cond ((and (null i) (null j)) t) ; paßt !
        ((and (atom i)(atom j))
         (cond ((eq i j) (anpassen (+ pos 1)))
               (t nil))) ; Konstanten müssen gleich sein !
        ((and (listp i)(atom j))
           (setq prädikat1 (austauschen i j prädikat1))
           (setq prädikat2 (austauschen i j prädikat2))
           (set (car i) j)
           (anpassen (+ pos 1)))
        ((and (atom i)(listp j))
           (setq prädikat1 (austauschen j i prädikat1))
           (setq prädikat2 (austauschen j i prädikat2))
           (set (car j) i)
           (anpassen (+ pos 1)))
        (t (setq prädikat1 (austauschen j i prädikat1))
           (setq prädikat2 (austauschen j i prädikat2))
           (set (car j) i)
           (anpassen (+ pos 1)))))

(defun austauschen (so ta prädikat)
  (cond ((null prädikat) nil)
        (t (cons (ersetzeTerm so ta (car prädikat))
           (austauschen so ta (cdr prädikat))))))

(defun ersetzeTerm (so ta term)
  (cond ((null term) nil)
        ((equal (car term) so) (cons ta (ersetzeTerm so ta (cdr term))))
        (t (cons (car term) (ersetzeTerm so ta (cdr term))))))

; damit gleichnamige Variablen verschiedener Terme richtig zugeordnet werden
(defun kennzeichneTerm (term id)
 (cond((null term) nil)
      ((atom (car term)) (cons (car term)(kennzeichneTerm (cdr term) id)))
      (t(cons (cons (car (car term)) (list id))
              (kennzeichneTerm (cdr term) id)))
  )
)
(defun kennzeichnePrädikat (prädikat id)
  (cond ((null prädikat) nil)
        (t (cons (kennzeichneTerm (car prädikat) id)
                 (kennzeichnePrädikat (cdr prädikat) id)))))
(defun kennzeichneDataBase (DataBase id)
  (cond ((null DataBase) nil)
        (t (cons (kennzeichnePrädikat (car DataBase) id)
                 (kennzeichneDataBase (cdr DataBase) (+ id 1))))))

(defun deMorgen (liste1 liste2) ;Wendet dieses Gesetz für and und not an
  (cond ((null liste1) nil) ;Alle oder-Alternativen haben nicht geklappt
        ((eq (car (car liste1) 'not)) ; not und not hebt sich auf
         (cond ((main (cons (cdr (car liste1)) liste2)) t)
               (t (deMorgen (cdr liste1) liste2))))
        (t (cond ((main (append liste2 (list (cons 'not (car liste1))))) t)
                 (t (deMorgen (cdr liste1) liste2))))))

(defun main (prädikat &aux i flag)
  (setq i 1)(setq flag nil)
  (while (and (not (null (nth i NewDataBase))) (null flag))
    (setq flag (match prädikat (nth i NewDataBase)))
    (setq i (+ i 1)))
  (cond ((and (listp flag) (not (null flag))) nil) ;nicht erf. Negation
        (t (cond ((eq (car (car prädikat)) 'not)
                  (cond ((null (cdr prädikat)) (VarAusgabe))
                        (t (main (cdr prädikat)))))
                 (t flag)))))

(defun generiereVarListe (prädikat)
 (cond ((null prädikat) nil)
       ((listp (car prädikat)) (cons (car (car prädikat))
                                      (generiereVarListe (cdr prädikat))))
       (t (generiereVarListe (cdr prädikat)))))

(defun VarAusgabe (&aux i)
  (setq i 1)
  (princ "t")(terpri)
  (while (not (null (nth i VarListe)))
    (princ (nth i VarListe) ":=" (eval (nth i VarListe)))(terpri)
    (setq i (+ i 1)))
  (princ "Weitersuchen (j/n) ?")
  (eq (read) 'n))

(defun prolog (prädikat)
  (setq VarListe (generiereVarListe (cdr prädikat)))
  (main (list prädikat)))

(defun init () (setq NewDataBase (kennzeichneDataBase database 1)))
(princ "Nach Veränderungen der Datenbasis ist (init) aufzurufen")(terpri)
(princ "Fragen an das System werden mit (prolog <Prädikat>) gerichtet.")
(terpri)
;---- Datenbasis ----

(setq database '(
  ((vater otto hans))((männlich hans)) ; Otto ist Vater von Hans
  ((vater otto ute)) ((weiblich ute))
  ((vater hans karl))((männlich karl))
  ((vater hans jörg))((männlich jörg))
  ((mutter ute anna))((weiblich anna))
  ((gleich (a) (a)))
  ((ungleich (a) (b)) (not gleich (a) (b)))
  ((elternteil (a) (b)) (vater (a) (b))) ; a Eleternteil von b
  ((elternteil (a) (b)) (mutter(a) (b)))
  ((geschwister (a) (b)) (elternteil (c) (a))(elternteil (c) (b))
                         (ungleich (a) (b)))
  ((kind (a)(b)) (vater (b)(a))) ; a ist Kind von b
  ((kind (a)(b)) (mutter (b)(a)))

  ((onkel (a)(b)) (männlich (a))(geschwister (c) (a)) (kind (c) (b)))
  ((tante (a)(b)) (weiblich (a))(geschwister (c) (a)) (kind (b) (c)))

))
(init)
(allow)