t3x.org / sketchy / prog / prolog.html
SketchyLISP Stuff Copyright (C) 2007 Nils M Holm

prolog

Language: R5RS Scheme

Purpose: A simple PROLOG interpreter.
 
This program is based on another tiny PROLOG interpreter written in MACLISP by Ken Kahn.
 
If the do-print function is set up to return #f this interpreter is completely free of side effects, and the PROLOG function returns its query results as a list of frames.

Arguments:
Q - query
DB - database

Implementation:

(define (do-print) #t)

(define (prolog q db)
  (letrec
    ((atom?
       (lambda (x)
         (or (null? x)
             (symbol? x))))
     ; Is X a variable?
     ; Variables look like this: (? name).
     (variable?
       (lambda (x)
         (and (not (atom? x))
              (eq? '? (car x)))))
     ; Create an environment of unique names by
     ; appending ID to each variable.
     (new-scope
       (lambda (x id)
         (letrec
           ((_new-scope (lambda (x)
              (cond ((atom? x) x)
                ((variable? x) (append x id))
                (else (cons (_new-scope (car x))
                            (_new-scope (cdr x))))))))
           (_new-scope x))))
     ; Increment ID.
     (nextid
       (lambda (x)
         (list (cons 'i (car x)))))
     ; Find the value of a variable in a given environment.
     ; If the variable is not bound, return its name
     ; else return the value of its value (variables may be
     ; bound to variables).
     (value
       (lambda (x env)
         (cond ((variable? x)
             (let ((b (assoc x env)))
               (if b (value (cdr b) env) x)))
           (else x))))
     ; Unify two expressions X and Y in a given environment.
     ; If X and Y can be unified, return a new environment in
     ; which the variables of X and Y are bound.
     ; If the unification fails, return '().
     ; Variables are unified by binding them.
     ; Atoms are unified if they are identical.
     ; Forms are unified by unifying their components.
     (unify
       (lambda (x y env)
         (let ((x (value x env))
               (y (value y env)))
           (cond
             ((variable? x) (cons (cons x y) env))
             ((variable? y) (cons (cons y x) env))
             ((atom? x) (if (eq? x y) env '()))
             ((atom? y) (if (eq? x y) env '()))
             (else (let ((newenv (unify (car x) (car y) env)))
                     (cond ((null? newenv) '())
                       (else (unify (cdr x) (cdr y) newenv)))))))))
     ; Attempt to unify each goal with each rule;
     ; Collect bindings created by unifications.
     ; RULES  = list of rules (database)
     ; GOALS  = conjunction of goals
     ; ENV    = environment to unify in
     ; ID     = scope ID
     ; RESULT = list of results so far
     (tryrules
       (lambda (rules goals env id result)
         (cond ((null? rules) result)
           (else (let* ((thisrule (new-scope (car rules) id))
                        (newenv (unify (car goals)
                                       (car thisrule)
                                       env)))
                   (cond ((null? newenv)
                       (tryrules (cdr rules) goals env id result))
                     (else (let ((res (prove (append (cdr thisrule)
                                                     (cdr goals))
                                             newenv (nextid id))))
                             (tryrules (cdr rules) goals env id
                               (append result res))))))))))
     ; Print results if (do-print) = #t
     (print
       (lambda (x)
         (cond ((do-print)
             (begin (display x)
                    (newline)
                    x))
           (else x))))
     ; Create an N-tuple of bindings
     ; ((VAR-1 . VALUE-1) ... (VAR-N . VALUE-N)).
     ; Each binding is prepresented by
     ; (VAR . VALUE),
     ; where VAR is the name and VALUE is the value
     ; of a variable bound in the outermost scope
     ; (the scope of the query).
     ; N is the number of variables in the query.
     (list-env
       (lambda (env)
         (letrec
           ((top-level?
              (lambda (x)
                (null? (caddr x))))
            (name-of
              cadr)
            (_list-env
              (lambda (e res)
                (cond ((null? (cdr e))
                    (list (print res)))
                  ((top-level? (caar e))
                    (_list-env (cdr e)
                      (cons (cons (name-of (caar e))
                                  (value (caar e) env))
                            res)))
                  (else (_list-env (cdr e) res))))))
           (_list-env env '()))))
     ; Prove a list of goals in a given environment.
     ; GOALS = list of goals
     ; ENV   = environment
     ; ID    = scope ID, see NEWSCOPE above
     (prove
       (lambda (goals env id)
         (cond ((null? goals) (list-env env)) 
           (else (tryrules db goals env id '()))))))
    ; '((())) is the initial environment. It looks like
    ; this because '(()) would indicate failure in UNIFY.
    (prove (list (new-scope q '(()))) '((())) '((i)))))

; This is a utility function to submit queries to
; a predefined database bound to DATABASE.
; The result is discarded.
; QUERY requires *PRINT* = #T.

(define (query q)
  (let ((result (prolog q database)))
    (cond ((equal? result '(())) 'yes)
      (else 'no))))

Example:

:load prolog.db
(prolog '(parent (? p) eric) database) 
=> (((p . bertram)) ((p . cathy)))