This is a multi-part message in MIME format.
--------------CC11A2B6F551C2C4BD9A3B95
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7bit
I've got a package implemented in scheme that is a prolog interpreter
along with the use of the unification algorithm. The loading of the
files seems to work fine, but when I run my sample queries (located in
file sample.p.scm) I get the error "The object (), passed as the first
argument to cdr, is not the correct type." Now I understand the error,
but I can't seem to correct it. I hope someone can lend a helping hand.
The files attached are:
prolog5.scm => the prolog interpreter
unifI.scm => the unification algorithm
sample.p.scm => sample database and queries.
Thanks for any help.
--------------CC11A2B6F551C2C4BD9A3B95
Content-Type: text/plain; charset=us-ascii; name="prolog5.scm"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline; filename="prolog5.scm"
;(define nil '())
(define *PROLOG-CLAUSES* '())
(define *TRACING* #t) ; Set to t to trace Prolog execution.
; The clause (<- A B C D) (that is, "to show A, show B, C, and D")
; is implemented as the list (A B C D).
; query is the top level retrieval function (a macro). It calls
; show to retrieve the goal, and then success-msg to report success
; or failure.
(define (query GOAL)
(let ((BDGS (show nil (list GOAL))))
(success-msg BDGS GOAL)))
; Report on the success of the top level goal.
(define (success-msg BDGS GOAL)
(cond (BDGS
(display "Succeeds:")
(write (replace-variables GOAL (car BDGS)))
(newline)
#t)
(else
(display "Fails:")
(newline)
#f)))
; Show is the main retrieval function. It is indirectly recursive.
; GOAL is the current goal; BDGS, the current variable bindings;
; AND-STACK, a stack of unsatisfied disjuncts.
; Show loops through all the clauses that are possibly relevant to GOAL,
; until it either exhausts the clauses, when it returns nil,
; or it finds a clause that is satisfiable, when it returns the
; bindings that satisfy the clause.
; Note that, throughout this code, bindings have an extra level of
; parentheses, to distinguish failure (which returns nil), from
; success with no variables (which returns (nil)). Thus if X is bound
; to A and Y to B, the binding list is (((X A) (Y B)))
(define (show BDGS AND-STACK)
(let* ((GOAL (car AND-STACK)) (AND-STACK (cdr AND-STACK)))
(letrec
((show1 ; recursively loops through CLAUSES
(lambda (CLAUSES)
(let ((CLAUSE (uniquify-variables (car CLAUSES))))
(cond ((null? CLAUSE)
(success-trace GOAL BDGS NIL)
#f)
(else
(let ((NEWBDGS (satisfy-goal GOAL CLAUSE BDGS AND-STACK)))
(cond (NEWBDGS
(success-trace GOAL NEWBDGS T)
NEWBDGS)
(else
(show1 (cdr CLAUSES)))))))))))
; Body of show
(cond (*TRACING*
(display "Goal: ")
(write (replace-variables GOAL (car BDGS))))
(newline)
(else '()))
(show1 (relevant-clauses GOAL)))))
; satisfy-goal checks whether CLAUSE can be used to satisfy GOAL under
; BDGS. If the head of the CLAUSE unifies, then add the tail of CLAUSE
; to AND-STACK. If AND-STACK is now empty, then succeed, else proceed to
; the next goal. If the head of CLAUSE does not unify, then fail.
(define (satisfy-goal GOAL CLAUSE BDGS AND-STACK)
(let ((NEWBDGS (unify1 GOAL (clause-head CLAUSE) (car BDGS))))
(cond (NEWBDGS
(set! AND-STACK (append (clause-tail CLAUSE) AND-STACK))
(if AND-STACK
(show NEWBDGS AND-STACK)
NEWBDGS))
(else '()))))
; *PROLOG-CLAUSES* is an association list of the form
; ((predicate CLAUSE CLAUSE ...)
; (predicate CLAUSE CLAUSE ...)
; ...)
; where each Prolog predicate P is associated with the clauses in which
; P is the predicate in the head of the clause.
; Retrieve the clauses that might unify with GOAL; namely, all those
; with the same leading predicate.
(define (relevant-clauses GOAL)
(cdr (assoc (predicate GOAL) *PROLOG-CLAUSES*)))
; Report success or failure of a goal in tracing
(define (success-trace GOAL BDGS SUCCESS)
(cond (*TRACING*
(newline)
(if SUCCESS (display "Succeeded: ") (display "Failed:"))
(write (replace-variables GOAL (car BDGS)))
(newline))
(else '())))
; Add CLAUSE as the first clause under its predicate.
(define (asserta CLAUSE)
(let* ((CLAUSE (clause-form CLAUSE))
(ALIST (assoc (lead-predicate CLAUSE) *PROLOG-CLAUSES*)))
(cond (ALIST
(set-cdr! ALIST (cons CLAUSE (cdr ALIST))))
(else
(set! *PROLOG-CLAUSES* (cons (list (lead-predicate CLAUSE) CLAUSE)
*PROLOG-CLAUSES*))))
CLAUSE))
; Add CLAUSE as the last clause under its predicate.
(define (assertz CLAUSE)
(let* ((CLAUSE (clause-form CLAUSE))
(ALIST (assoc (lead-predicate CLAUSE) *PROLOG-CLAUSES*)))
(cond (ALIST
(nconc! ALIST (list CLAUSE)))
(else
(set! *PROLOG-CLAUSES* (cons (list (lead-predicate CLAUSE) CLAUSE)
*PROLOG-CLAUSES*))))
CLAUSE))
; (nconc! L M) destructively appends M to L
(define (nconc! L M)
(if (cdr L)
;(not (null? (cdr L)))
(nconc! (cdr L) M)
(set-cdr! L M)))
; Reformat the input clause with a <- as a clause structure.
(define (clause-form CLAUSE)
(if (eqv? (car CLAUSE) '<-)
(cdr CLAUSE)
(list CLAUSE)))
(define (lead-predicate CLAUSE) (predicate (clause-head CLAUSE)))
(define (predicate FORM) (car FORM))
(define (clause-head CLAUSE) (car CLAUSE))
(define (clause-tail CLAUSE) (cdr CLAUSE))
(define atom?(lambda x
(not (pair? x))))
--------------CC11A2B6F551C2C4BD9A3B95
Content-Type: text/plain; charset=us-ascii; name="unifI.scm"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline; filename="unifI.scm"
(define (pcvar? PAT)
(and (pair? PAT) (eqv? (car PAT) '*VAR*)))
(define (pcvar-id PAT) (cadr PAT))
(define (make-pcvar VAR) (list '*VAR* VAR))
; (uniquify-variables PAT) replaces (non-destructively) the variables
; in PAT with new variables of the same print name.
(define (uniquify-variables PAT)
(let ((NEW-NAMES (rename-list PAT NIL)))
(if (null? NEW-NAMES)
PAT
(rename-variables PAT NEW-NAMES))))
; (rename-list PAT nil) returns an association list of all the variables
; in PAT together with the new replacement variables. The variable NEW-NAMES
; gradually accumulates the association list.
(define (rename-list PAT NEW-NAMES)
(cond ((pcvar? PAT)
(let ((ID (pcvar-id PAT)))
(cond ((assoc ID NEW-NAMES) NEW-NAMES)
(else
(cons (list ID
(make-pcvar (generate-uninterned-symbol ID)))
NEW-NAMES)))))
((atom? PAT) NEW-NAMES)
(else
(rename-list (car PAT) (rename-list (cdr PAT) NEW-NAMES)))))
; (rename-variables PAT NEW-NAMES) replaces the variables in PAT
; with the new variables associated in NEW-NAMES.
(define (rename-variables PAT NEW-NAMES)
(cond ((pcvar? PAT)
(or (associated (pcvar-id PAT) NEW-NAMES) PAT))
((atom? PAT) PAT)
(else
(cons (rename-variables (car PAT) NEW-NAMES)
(rename-variables (cdr PAT) NEW-NAMES)))))
; (replace-variables FORM BDGS) modifies FORM with the bindings in BDGS
; For example, (replace-variables '(YOUNGER ?X (FATHER ?X)) '((X JOHN)))
; returns (YOUNGER JOHN (FATHER JOHN)).
(define (replace-variables FORM BDGS)
(cond ((pcvar? FORM)
(cond ((let ((VAL (sym-lookup FORM BDGS)))
(replace-variables VAL BDGS)))
(else FORM)))
((atom? FORM) FORM)
(else
(cons (replace-variables (car FORM) BDGS)
(replace-variables (cdr FORM) BDGS)))))
; (unify PAT1 PAT2) returns a list of the list of bindings which unify
; PAT1 with PAT2. The code assumes that the two patterns have no common
; variables. The function returns nil if the patterns cannot be
; unified; (nil) if the patterns can be unified with no substitutions;
; and (list of bindings) if the patterns can be unified with some
; substitutions. For example,
; (unify '(IS CLYDE ?X) '(IS ?Y ELEPHANT)) returns (((Y CLYDE) (X ELEPHANT)))
; Note that one level of parethesization must be stripped off before
; passing the result to replace-variables.
; Initialize the list of substitutions to nil, and call the recursive
; unify1.
(define (unify PAT1 PAT2)
(unify1 PAT1 PAT2 nil))
; Unify PAT1 with PAT2 with substitutions SUB.
; If either pattern is a variable, unify it, if possible, with the
; other pattern; else, if one is an atom, the other must be the same
; atom; else the cars must be unifiable, and the cdrs must
; be unifiable under the substitutions which unify the cars.
(define (unify1 PAT1 PAT2 SUB)
(cond ((pcvar? PAT1)
(var-unify PAT1 PAT2 SUB))
((pcvar? PAT2)
(var-unify PAT2 PAT1 SUB))
((atom? PAT1)
(and (eqv? PAT1 PAT2) (list SUB)))
((atom? PAT2) nil)
(else
(let ((CAR-SUBSTS (unify1 (car PAT1) (car PAT2) SUB)))
(and CAR-SUBSTS
(unify1 (cdr PAT1) (cdr PAT2) (car CAR-SUBSTS)))))))
; (var-unify V PAT SUB) unifies variable V with pattern P under
; substitution SUB. If V is bound in SUB, unify the binding of
; V with PAT. Otherwise, add the binding of V with P to SUB.
(define (var-unify V PAT SUB)
(let ((VAR (pcvar-id V)) (BDG (sym-lookup V SUB)))
(cond (BDG
(unify1 BDG PAT SUB))
((var-equal V PAT)
(list SUB))
((not (occurs-in V PAT SUB))
(list (cons (list VAR PAT) SUB))))))
(define (occurs-in V P SUB)
(cond ((pcvar? P)
(or (var-equal V P)
(let ((B (sym-lookup P SUB)))
(and B (occurs-in V B SUB)))))
((atom? P) nil)
(else
(there-exists? P (lambda (Y) (occurs-in V Y SUB))))))
(define (there-exists? L F)
(and L
(or (F (car L))
(there-exists? (cdr L) F))))
(define (var-equal V1 V2)
(and (pcvar? V1) (pcvar? V2)
(eqv? (pcvar-id V1) (pcvar-id V2))))
; Looks up variable V in substitution list SUB.
(define (sym-lookup V SUB)
(associated (pcvar-id V) SUB))
(define (associated X ALIST)
(cadr (assoc X ALIST)))
--------------CC11A2B6F551C2C4BD9A3B95
Content-Type: text/plain; charset=us-ascii; name="sample.p.scm"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline; filename="sample.p.scm"
;(set! *PROLOG-CLAUSES* nil)
; Small family tree
(assertz '(parent PHILIP CHARLES))
(assertz '(parent ELIZABETH CHARLES))
(assertz '(parent CHARLES WILLIAM))
; Recursive definition of ancestor.
(assertz '(ancestor (*VAR* X) (*VAR* X)))
(assertz '(<- (ancestor (*VAR* X) (*VAR* Y))
(parent (*VAR* X) (*VAR* Z))
(ancestor (*VAR* Z) (*VAR* Y))))
; Arithmetic on unary numerals (that is, numbers in the form
; (s (s (s (s 0)))) (= 4)
(assertz '(plus 0 (*VAR* M) (*VAR* M)))
(assertz '(<- (plus (s (*VAR* M)) (*VAR* A) (s (*VAR* B)))
(plus (*VAR* M) (*VAR* A) (*VAR* B))))
(assertz '(times 0 (*VAR* M) 0))
(assertz '(<- (times (s (*VAR* A)) (*VAR* B) (*VAR* C))
(times (*VAR* A) (*VAR* B) (*VAR* D))
(plus (*VAR* D) (*VAR* B) (*VAR* C))))
; Sample queries
; (query '(parent elizabeth (*VAR* X)))
; (query '(ancestor elizabeth william))
; (query '(plus (s (s 0)) (s (s 0)) (*VAR* M))))
; (query '(times (s (s 0)) (s (s 0)) (*VAR* P))))
; (query '(plus (*VAR* A) (s (s 0)) (s (s (s (s 0))))))
; (query '(times (*VAR* F) (s (s 0)) (s (s (s (s 0))))))
--------------CC11A2B6F551C2C4BD9A3B95--
This is a wonderful idea. I've been debugging my program for several
months now. It would be nice to post it to the newsgroup and learn what
the rest of the bugs are.
Neil Cohen
Please remove the .spamkill before replying.
Mitch <·······@psnw.com> writes:
> I get the error "The object (), passed as the first
> argument to cdr, is not the correct type." Now I understand the error,
> but I can't seem to correct it.
Here's a quick guess.
> (define (nconc! L M)
> (if (cdr L)
> ;(not (null? (cdr L)))
> (nconc! (cdr L) M)
> (set-cdr! L M)))
The empty list counts as true in Scheme and is here passed on to be
cdr'd just when the programmer trusted it to be counted as false.
--
Jussi