klisp-rust/prolog at main · kathe/klisp-rust · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
;; Tiny PROLOG
;;
;; This program is based on a tiny Prolog interpreter in MacLisp
;; by Ken Kahn, as published in SAIL AIList Digest V1, #47, 1983.
;;
;; I (NMH) have applied the following modifications:
;; - translation to Kilo LISP
;; - variables are resolved in list values, so lists
;;   can be used in goals, see APPEND example
;; - all frames print without user interaction
;; - renaming uses atoms, because there are no numbers
;; - TRY (formerly TRY-EACH) function has fewer variables
;; - variable names are shorter

(setq varp
  (lambda (x)
    (and (not (atom x))
         (eq (car x) '//))))

(setq lookup
  (lambda (x a)
    (cond ((null a) nil)
          ((equal x (caar a)) (car a))
          (else (lookup x (cdr a))))))

(setq value
  (lambda (x e)
    (if (varp x)
        (let ((b (lookup x e)))
          (if (null b)
              x
              (value (cadr b) e)))
        x)))

(setq rename
  (lambda (term n)
    (cond ((atom term) term)
          ((varp term) (conc term n))
          (else (cons (rename (car term) n)
                      (rename (cdr term) n))))))

(setq resolve
  (lambda (x e)
    (cond ((atom x) x)
          ((varp x) (resolve (value x e) e))
          (else (cons (resolve (car x) e)
                      (resolve (cdr x) e))))))

(setq prframes
  (lambda (e)
    (print '/ )
    (loop pr ((ee e))
      (cond ((cdr ee)
              (cond ((eq '0 (caddr (caar ee)))
                      (prin (cadr (caar ee)))
                      (prin '/=)
                      (print (resolve (caar ee) e))))
              (pr (cdr ee)))))))

(setq unify
  (lambda (x y e)
    (let ((x (value x e))
          (y (value y e)))
      (cond ((varp x) (cons (list x y) e))
            ((varp y) (cons (list y x) e))
            ((or (atom x) (atom y))
              (and (eq x y) e))
            (else
              (let ((ne (unify (car x) (car y) e)))
                (and ne (unify (cdr x) (cdr y) ne))))))))

(setq succ
  (lambda (x)
    (let ((n (memb x #01234567890abcdefghijklmnopqrstuvwxyz)))
      (if (or (null n)
              (null (cdr n)))
          (error 'too/ many/ variables)
          (cadr n)))))

(setq try
  (lambda (goals rules db e n)
    (if (null rules)
        nil
        (let ((asn (rename (car rules) (list n))))
          (let ((ne (unify (car goals) (car asn) e)))
            (cond ((null ne)
                    (try goals (cdr rules) db e n))
                  ((prove (conc (cdr asn) (cdr goals))
                          ne
                          db
                          (succ n)))
                  (else
                    (try goals (cdr rules) db e n))))))))

(setq prove
  (lambda (goals e db n)
    (cond ((null goals)
            (prframes e))
          (else
            (try goals db db e n)))))

(setq prolog
  (lambda (db goal)
    (prove (list (rename goal '(0)))
           '((bottom))
           db
           '1)))

(setq db '(((append nil (// l) (// l)))
           ((append ((// x) . (// xs)) (// ys) ((// x) . (// zs)))
            (append (// xs) (// ys) (// zs)))))

%

(setq db '(((man socrates))
           ((mortal (// x))
            (man (// x)))))

(setq db '(((father jack ken))
           ((father jack karen))
           ((grandparent (// grandparent) (// grandchild))
            (parent (// grandparent) (// parent))
            (parent (// parent) (// grandchild)))
           ((mother el ken))
           ((mother cele jack))
           ((parent (// parent) (// child))
            (mother (// parent) (// child)))
           ((parent (// parent) (// child))
            (father (// parent) (// child)))))