home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 02 / levelki / pil.lsp < prev    next >
Encoding:
Text File  |  1988-11-23  |  3.3 KB  |  111 lines
  1. ; Simple Prolog Interpreter in LittleLisp - based
  2. ; on pil from xlisp
  3.  
  4. (define (prolog database)
  5.   (let ((goal (begin (print '?-) (read))))
  6.     (prove (list (rename goal '(0)))
  7.            '((bottom-of environment))
  8.            database
  9.            1))
  10.   (prolog database))
  11.  
  12. (define (prove goals env db level)
  13.   (cond ((null? goals)
  14.          (pbind env env)
  15.          (not (y-or-n-p "More?")))
  16.         (t (try db db
  17.                 (cdr goals) (car goals)
  18.                 env level))))
  19.  
  20. (define (try dbl db gl goal env l)
  21.   (let ((ass nil) (new nil))
  22.     (cond ((null? dbl) ())
  23.           (t (set! ass (rename (car dbl) (list l)))
  24.              (set! new (unify goal (car ass) env))
  25.              (try1 new dbl db gl goal env l ass)))))
  26.  
  27. (define (try1 new b db gl goal env l ass)
  28.  (let ((d nil))
  29.   (cond ((null? new)
  30.          (try (cdr b) db gl goal env l))
  31.         ((set! d (prove (append (cdr ass) gl) new db (+ 1 l))) d)
  32.         (t (try (cdr b) db gl goal env l)))))
  33.  
  34. (define (unify x y env)
  35.   (unify1 (value x env) (value y env) env))
  36.  
  37. (define (unify1 x y env)
  38.   (cond ((var? x) (cons (list x y) env))
  39.         ((var? y) (cons (list y x) env))
  40.         ((or (atom? x) (atom? y))
  41.          (cond ((eq? x y) env)
  42.                (t nil)))
  43.         (else (list-unify x y env))))
  44.  
  45. (define (list-unify x y env)
  46.   (let ((new (unify (car x) (car y) env)))
  47.     (cond (new (unify (cdr x) (cdr y) new))
  48.           (else nil))))
  49.  
  50. (define (value x env)
  51.   (let ((binding nil))
  52.     (cond ((var? x)
  53.            (set! binding (assoc x env))
  54.            (cond ((null? binding) x)
  55.                  (t (value (nth 2 binding) env))))
  56.           (t x))))
  57.  
  58. (define (expand x env)
  59.   (let ((binding nil))
  60.    (cond ((var? x) (set! binding (assoc x env))
  61.           (if (null? binding) x (expand (cadr binding) env)))
  62.          ((atom? x) x)
  63.          (else (cons (expand (car x) env)
  64.                      (expand (cdr x) env))))))
  65.  
  66. (define (var? x)
  67.   (and x (pair? x) (eq? (car x) '?)))
  68.  
  69. (define (rename term list-of-level)
  70.   (cond ((var? term) (append term list-of-level))
  71.         ((atom? term) term)
  72.         (t (cons (rename (car term) list-of-level)
  73.                  (rename (cdr term) list-of-level)))))
  74.  
  75. (define (pbind env-left env)
  76.   (cond ((cdr env-left)
  77.          (cond ((= 0 (nth 3 (caar env-left)))
  78.                 (print
  79.                   (nth 2 (caar env-left)))
  80.                 (print '=)
  81.                 (print (expand (caar env-left) env))
  82.                 (newline)))
  83.          (pbind (cdr env-left) env))))
  84.  
  85. (define db-1 '(((father jack ken))
  86.               ((father jack karen))
  87.               ((grandparent (? gp) (? gc))
  88.                (parent (? gp) (? p))
  89.                (parent (? p) (? gc)))
  90.               ((mother el ken))
  91.               ((mother cele jack))))
  92. (define db-2 '(((parent (? p) (? c))
  93.                 (mother (? p) (? c)))
  94.                ((parent (? p) (? c))
  95.                 (father (? p) (? c)))))
  96. (define db (append db-1 db-2))
  97.  
  98. (define db1 '(((app () (? x) (? x)))
  99.               ((app ((? h) . (? t)) (? l) ((? h) . (? r)))
  100.                (app (? t) (? l) (? r)))))
  101.  
  102. (define (y-or-n-p prompt)
  103.   (print prompt)
  104.   (eq? (read) 'y))
  105.  
  106. (define (nth n l)
  107.   (cond ((= 1 n) (car l))
  108.         ((= 2 n) (cadr l))
  109.         ((= 3 n) (car (cddr l)))
  110.         (else nil)))
  111.