As laid out in my previous post, I am porting from Common Lisp to Racket the Prolog interpreter exposed in Peter Norvig’s classic text, Paradigms of Artificial Intelligence Programming: Case Studies in Common Lisp 1st Edition, also known as PAIP, in its chapter 11.
This second post covers interpreter’s second version, exposed in sections 11.3 though 11.5. And, as the first post, it focuses on its port, from its original implementation in Common Lisp, to Racket, in the main differences between its implementation in each of these Lisp dialects. Hence, for every modification, we will compare below the initial version under the title Section 11.2, with the new one, under Section 11.3, in their original implementation, in Common Lisp. Code ported to Racket will be exposed under this section as well.
Source code available in my GitHub repo, branch section-11.3.
The first version of the interpreter, exposed in the previous post, for every query, returns all the solutions at once, in a manner PAIP calls “batch approach”. On the other hand, its second version, about to be exposed here, for every query returns one solution at a time, as they are found, as usual in real Prolog interpreters: PAIP calls this approach “incremental”.
In order to implement it, PAIP uses a specific goal which “extends every query to print out the variables, and ask the user if the computation should be continued”. This is a new type of goal, which is independent of the database but “causes a procedure to take action. In Prolog, such procedures are called primitives, because they are built-in to the language”.
The first, actually unique primitive procedure included in this new version, show-prolog-vars, appears in top-level-prove function, which is directly by query operator.
(defun top-level-prove (goals)
"Prove the goals, and print variables readably."
(show-prolog-solutions
(variables-in goals)
(prove-all goals no-bindings)))
(defun top-level-prove (goals)
(prove-all `(,@goals (show-prolog-vars ,@(variables-in goals)))
no-bindings)
(format t "~&No.")
(values))
As mentioned above, primitive show-prolog-vars is left to the very end of the list of goals.
And then, its port to Racket:
;; Prove the goals, and print variables readably
(define (top-level-prove goals)
(prove-all `(,@goals (show-prolog-vars ,@(variables-in goals)))
no-bindings)
(printf "No.")
(values))
Then, we approach prove-all function. As explained above, in this new version, with “incremental approach”, for every query, just one solution at a time is returned, as they are found:
(defun prove-all (goals bindings)
"Return a list of solutions to the conjunction of goals."
(cond ((eq bindings fail) fail)
((null goals) (list bindings))
(t (mapcan #'(lambda (goal1-solution)
(prove-all (rest goals) goal1-solution))
(prove (first goals) bindings)))))
(defun prove-all (goals bindings)
"Find a solution to the conjunction of goals."
(cond ((eq bindings fail) fail)
((null goals) bindings)
(t (prove (first goals) bindings (rest goals)))))
And then, its port to Racket:
;; Return a list of solutions to the conjunction of goals
(define (prove-all goals bindings)
(cond ((equal? bindings fail) fail)
((null? goals) (list bindings))
(else (prove (car goals) bindings (cdr goals)))))
Then, we go on with prove function.
(defun prove (goal bindings)
"Return a list of possible solutions to goal."
(mapcan #'(lambda (clause)
(let ((new-clause (rename-variables clause)))
(prove-all (clause-body new-clause)
(unify goal (clause-head new-clause) bindings))))
(get-clauses (predicate goal))))
(defun prove (goal bindings other-goals)
"Return a list of possible solutions to goal."
(let ((clauses (get-clauses (predicate goal))))
(if (listp clauses)
(some
#'(lambda (clause)
(let ((new-clause (rename-variables clause)))
(prove-all
(append (clause-body new-clause) other-goals)
(unify goal (clause-head new-clause) bindings))))
clauses)
;; The predicate's "clauses" can be an atom:
;; a primitive function to call
(funcall clauses (rest goal) bindings
other-goals))))
This last funcall invokes primitives.
And then, its port to Racket:
;; Return a 1ist of possible solutions to goal
(define (prove goal bindings other-goals)
(let* ((pred (predicate goal))
(clauses (get-clauses pred)))
(if (null? clauses)
;; The predicate's "clauses" can be an atom:
;; a primitive function to call
(eval `(,pred ',(rest goal) ',bindings ',other-goals))
(for/or ((clause clauses))
(let ((new-clause (rename-variables clause)))
(prove-all
(append (clause-body new-clause) other-goals)
(unify goal (clause-head new-clause) bindings)))))))
For primitives to be picked by the if condition in previous snippet, the corresponding symbol had to be inserted in the clauses dictionary. This is performed in a slightly different manner in Racket than in Common Lisp:
(setf (get 'show-prolog-vars 'clauses) 'show-prolog-vars)
And then, its port to Racket:
(hash-set! db-predicates 'show-prolog-vars null)
Then, we go on with primitive show-prolog-vars function implementation:
(defun show-prolog-vars (vars bindings)
"Print each variable with its binding."
(if (null vars)
(format t "~&Yes")
(dolist (var vars)
(format t "~&~a = ~a" var
(subst-bindings bindings var))))
(princ ";"))
(defun show-prolog-vars (vars bindings other-goals)
"Print each variable with its binding.
Then ask the user if more solutions are desired."
(if (null vars)
(format t "~&Yes")
(dolist (var vars)
(format t "~&~a = ~a" var
(subst-bindings bindings var))))
(if (continue-p)
fail
(prove-all other-goals bindings)))
And then, its port to Racket:
;; Print each variable with its binding
(define (show-prolog-vars vars bindings other-goals)
(if (null? vars)
(printf "Yes~%")
(for ((var vars))
(printf "~a = ~a~%"
var
(subst-bindings bindings var))))
(if (continue?)
fail
(prove-all other-goals bindings)))
And the following predicate, referenced from show-prolog-vars function above, is added in section 11.3:
(defun continue-p ()
"Ask user if we should continue looking for solutions."
(case (read-char)
(#\; t)
(#\. nil)
(#\newline (continue-p))
(otherwise
(format t " Type ; to see more or . to stop")
(continue-p))))
And then, its port to Racket:
;; Ask user if we should continue looking for solutions
(define (continue?)
(case (read-char)
((#\;) #t)
((#\.) #f)
((#\newline) (continue?))
(else
(printf "Type ; to see more or . to stop")
(continue?))))
This are the usage examples given in PAIP, along with the result got in its port to Racket which, in turn, matches the result given in PAIP:
> (<- (member ?item (?item . ?rest)))
> (<- (member ?item (?x . ?rest)) (member ?item ?rest))
> (?- (member 2 (1 2 3)))
Yes;
No.
> (?- (member 2 (1 2 3 2 1)))
Yes;
Yes;
No.
> (<- (length () 0))
> (<- (length (?x . ?y) (1+ ?n)) (length ?y ?n))
> (?- (length (a b c d) ?n))
?n = (1+ (1+ (1+ (1+ 0))));
No.
This kind of variable denote the ones which are not relevant, represented with a question mark, ?. In the following example, variable?x used in the first two expressions below, are replaced by an anonymous variable in the subsequent two:
(<- (member ?item (?item . ?rest)))
(<- (member ?item (?x . ?rest)) (member ?item ?rest))
(<- (member ?item (?item . ?)))
(<- (member ?item (? . ?rest)) (member ?item ?rest))
They are implemented by the following functions:
(defmacro <- (&rest clause)
"Add a clause to the data base."
`(add-clause ',clause))
(defmacro ?- (&rest goals) `(top-level-prove ',goals))
(defun variables-in (exp)
"Return a list of all the variables in EXP."
(unique-find-anywhere-if #'variable-p exp))
(defmacro <- (&rest clause)
"add a clause to the data base."
`(add-clause ',(replace-?-vars clause)))
(defmacro ?- (&rest goals) `(top-level-prove ',(replace-?-vars goals)))
(defun replace-?-vars (exp)
"Replace any ? within exp with a var of the form ?123."
(cond ((eq exp '?) (gensym "?"))
((atom exp) exp)
(t (reuse-cons (replace-?-vars (first exp))
(replace-?-vars (rest exp))
exp))))
(defun variables-in (exp)
"Return a list of all the variables in EXP."
(unique-find-anywhere-if #'non-anon-variable-p exp))
(defun non-anon-variable-p (x)
(and (variable-p x) (not (eq x '?))))
And then, its port to Racket:
;; Add a clause to the data base
(define-syntax-rule (<- fact1 ...)
(add-clause (replace-?-vars '(fact1 ...))))
(define-syntax-rule (?- goal1 ...)
(top-level-prove (replace-?-vars '(goal1 ...))))
;; Replace any ? within exp with a var of the form ?123
(define (replace-?-vars exp)
(cond ((equal? exp '?) (gensym "?"))
((not (cons? exp)) exp)
(else (reuse-cons (replace-?-vars (car exp))
(replace-?-vars (cdr exp))
exp))))
;; Return a list of all the variables in EXP
(define (variables-in exp)
(unique-find-anywhere-if non-anon-variable? exp))
(define (non-anon-variable? x)
(and (variable? x) (not (eq? x '?))))
This is the final example given PAIP: a logic game.
(<- (member ?item (?item . ?rest)))
(<- (member ?item (?x . ?rest)) (member ?item ?rest))
(<- (nextto ?x ?y ?list) (iright ?x ?y ?list))
(<- (nextto ?x ?y ?list) (iright ?y ?x ?list))
(<- (iright ?left ?right (?left ?right . ?rest)))
(<- (iright ?left ?right (?x . ?rest))
(iright ?left ?right ?rest))
(<- (= ?x ?x))
(<- (zebra ?h ?w ?z)
;; Each house is of the form:
;; (house nationality pet cigarette drink house-color)
(= ?h ((house norwegian ? ? ? ?) ; 1, 10
?
(house ? ? ? milk ?) ? ?)) ; 9
(member (house englishman ? ? ? red) ?h) ; 2
(member (house spaniard dog ? ? ?) ?h) ; 3
(member (house ? ? ? coffee green) ?h) ; 4
(member (house ukrainian ? ? tea ?) ?h) ; 5
(iright (house ? ? ? ? ivory) ; 6
(house ? ? ? ? green) ?h)
(member (house ? snails winston ? ?) ?h) ; 7
(member (house ? ? kools ? ye1low) ?h) ; 8
(nextto (house ? ? chesterfield ? ?) ; 11
(house ? fox ? ? ?) ?h)
(nextto (house ? ? kools ? ?) ; 12
(house ? horse ? ? ?) ?h)
(member (house ? ? luckystrike orange-juice ?) ?h) ; 13
(member (house japanese ? parliaments ? ?) ?h) ; 14
(nextto (house norwegian ? ? ? ?) ; 15
(house ? ? ? ? blue) ?h)
;; Now for the questions:
(member (house ?w ? ? water ?) ?h) ; Q1
(member (house ?z zebra ? ? ?) ?h)) ; Q2
(?- (zebra ?houses ?water-drinker ?zebra-owner))
> (?- (zebra ?houses ?water-drinker ?zebra-owner))
?zebra-owner = japanese
?water-drinker = norwegian
?houses = ((house norwegian fox kools water ye1low) (house ukrainian horse chesterfield tea blue) (house englishman snails winston milk red) (house spaniard dog luckystrike orange-juice ivory) (house japanese zebra parliaments coffee green));
No.
In previous post, under this same title, “a couple Common Lisp primitive functions had to be re-implemented in Racket, in order to alter the least PAIP’s functions using them: sublis and adjoin. While porting this second version of the interpreter, I realized sublis handled just lists, whereas it had to handle pairs as well.
Hence, a new version with this new functionality was developed:
(define (sublis pairs lst)
(map (lambda (elem)
(process pairs elem))
lst))
(define (process pairs elem)
(cond ((list? elem) (sublis pairs elem))
((pair? elem) (subpair pairs elem))
(else (subelem pairs elem))))
(define (subpair pairs pair)
(cons (process pairs (car pair)) (process pairs (cdr pair))))
(define (subelem pairs elem)
(let ((mem-pairs (memf (lambda (pair)
(equal? elem (car pair)))
pairs)))
(if (not mem-pairs)
elem
(cdr (car mem-pairs)))))
And that’s all by now…
Source code available in my repo, at GitHub, branch section-11.3.
From this base, I plan to go on, with the steps listed below:
I hope this information to be useful for you ! And till next post !