Bubblegumdrop/cl-prolog
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit for git.lain.church

Browse Source
This commit is contained in:
Bubblegumdrop 2024-09-21 20:43:41 -04:00
commit b71f692fef
16 changed files with 909 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
*.fasl
bin/
systems/

48
cl-prolog.asd Normal file
View File

@ -0,0 +1,48 @@
(asdf:defsystem "cl-prolog"
:description "Prolog Compiler/Interpreter"
:author "Charlie Svitlik <staticsunn@gmail.com>"
:version "0.1.0"
:license "GPLv3+"
:defsystem-depends-on (:deploy)
:depends-on ()
:components ((:module "src"
:components
((:file "package")
(:file "constants")
(:file "utils")
(:file "bindings")
(:file "unify")
(:file "destructive-unify")
(:file "interp")
(:file "compiler")
(:file "compiler-macro")
(:file "cl-prolog"))))
:in-order-to ((test-op (test-op "cl-prolog/tests")))
:build-pathname "cl-prolog"
:entry-point "cl-prolog:main"
:build-operation "deploy-op")
(asdf:defsystem "cl-prolog/tests"
:description "Test system for cl-prolog"
:author "Charlie Svitlik <staticsunn@gmail.com>"
:license "WTFPL 2+"
:depends-on ("cl-prolog"
"rove")
:components ((:module "tests"
:components
((:file "cl-prolog"))))
:perform (asdf:test-op (op c) (symbol-call :rove :run c)))
;; https://lisp-journey.gitlab.io/blog/lisp-for-the-web-build-standalone-binaries-foreign-libraries-templates-static-assets/
(deploy:define-hook (:deploy asdf) (directory)
;; Thanks again to Shinmera.
(declare (ignorable directory))
#+asdf (asdf:clear-source-registry)
#+asdf (defun asdf:upgrade-asdf () nil))
;; https://lispcookbook.github.io/cl-cookbook/scripting.html#building-a-smaller-binary-with-sbcls-core-compression
#+sb-core-compression
(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
(uiop:dump-image (asdf:output-file o c)
:executable t
:compression t))

5
readme.org Normal file
View File

@ -0,0 +1,5 @@
* What It Is
Based on the Prolog interpreter/compiler from ``Paradigms of
Artificial Intelligence Programming: Case Studies in Common Lisp'' by
Peter Norvig.

71
src/bindings.lisp Normal file
View File

@ -0,0 +1,71 @@
(in-package #:cl-prolog)
(defun variable-p (x)
"Is X a variable (a SYMBOL beginning with '?')?"
(and (symbolp x)
(equal (char (symbol-name x) 0) #\?)))
(defun has-variable-p (x)
"Is there a variable anywhere in the expression X?"
(find-if-anywhere #'variable-p x))
(defun variables-in (exp)
"Return a list of all the variables in EXP."
(unique-find-anywhere-if #'variable-p exp))
(defun get-binding (var bindings)
"Find a (VARIABLE . VALUE) pair in a binding list."
(assoc var bindings))
(defun binding-val (binding)
"Get the value part of a single BINDING."
(cdr binding))
(defun lookup (var bindings)
"Get the value part (for VAR) from a binding list."
(binding-val (get-binding var bindings)))
(defun extend-bindings (var val bindings)
"Add a (VAR . VALUE) pair to a binding list."
(cons (cons var val)
;; Once we add a "real" binding, we can get rid of the dummy NO-BINDINGS
(if (eq bindings no-bindings)
nil
bindings)))
(defun subst-bindings (bindings x)
"Substitute the value of variables in BINDINGS into X, taking
recursively bound variables into account."
(cond ((eq bindings fail) fail)
((eq bindings no-bindings) x)
((and (variable-p x)
(get-binding x bindings))
(subst-bindings bindings (lookup x bindings)))
((atom x) x)
(t (reuse-cons (subst-bindings bindings (car x))
(subst-bindings bindings (cdr x))
x))))
(defun bind-unbound-vars (parameters exp)
"If there are any variables in exp (besides the parameters) then bind them to new vars."
(let ((exp-vars (set-difference (variables-in exp) parameters)))
(if exp-vars
`(let ,(mapcar #'(lambda (var) `(,var (?)))
exp-vars)
,exp)
exp)))
(defun bind-variables-in (exp bindings)
"Bind all variables in EXP to themselves, and add that to BINDINGS (except for variables already bound)."
(dolist (var (variables-in exp))
(unless (get-binding var bindings)
(setf bindings (extend-bindings var var bindings))))
bindings)
(defun follow-binding (var bindings)
"Get the ultimate binding of VAR according to BINDINGS."
(let ((b (get-binding var bindings)))
(if (eq (car b) (cdr b))
b
(or (follow-binding (cdr b) bindings)
b))))

4
src/cl-prolog.lisp Normal file
View File

@ -0,0 +1,4 @@
(in-package #:cl-prolog)
(defun main ()
)

31
src/compiler-macro.lisp Normal file
View File

@ -0,0 +1,31 @@
(in-package #:cl-prolog)
(defmacro def-prolog-compiler-macro (name arglist &body body)
"Define a compiler macro for Prolog."
`(setf (get ',name 'prolog-compiler-macro)
#'(lambda ,arglist .,body)))
(def-prolog-compiler-macro = (goal body cont bindings)
(let ((args (args goal)))
(if (/= (length args) 2)
:pass ;; Decline to handle this goal
(multiple-value-bind (code1 bindings1)
(compile-unify (first args) (second args) bindings)
(compile-if
code1
(compile-body body cont bindings1))))))
(def-prolog-compiler-macro and (goal body cont bindings)
(compile-body (append (args goal) body) cont bindings))
(def-prolog-compiler-macro or (goal body cont bindings)
(let ((disjuncts (args goal)))
(case (length disjuncts)
(0 fail)
(1 (compile-body (cons (first disjuncts) body) cont bindings))
(t (let ((fn (gensym "F")))
`(flet ((,fn () ,(compile-body body cont bindings)))
.,(maybe-add-undo-bindings
(loop for g in disjuncts collect
(compile-body (list g) `#',fn
bindings)))))))))

280
src/compiler.lisp Normal file
View File

@ -0,0 +1,280 @@
(in-package #:cl-prolog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun prolog-compile (symbol &optional (clauses (get-clauses symbol)))
"Compile a SYMBOL; make a separate function for each arity."
(unless (null clauses)
(let ((arity (relation-arity (clause-head (first clauses)))))
;; Compile the cluases with this arity
(compile-predicate symbol arity (clauses-with-arity clauses #'= arity))
;; Compile all the clauses with any other arity
(prolog-compile symbol (clauses-with-arity clauses #'/= arity)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun clauses-with-arity (clauses test arity)
"Return all clauses whose head has given arity."
(find-all arity clauses
:key #'(lambda (clause) (relation-arity (clause-head clause)))
:test test))
(defun relation-arity (relation)
"The number of arguments to a relation.
Example (Relation-arity '(p a b c)) => 3"
(length (args relation)))
(defun args (x)
"The arguments of a relation"
(rest x))
(defun make-parameters (arity)
"Return the list (?ARG1 ?ARG2 ... ?ARG-ARITY)"
(loop for i from 1 to arity
collect (alexandria:symbolicate
(format nil "?ARG~a" i))))
(defun make-predicate (symbol arity)
"Return the SYMBOL :SYMBOL/ARITY"
(alexandria:symbolicate
(string-upcase (format nil "~a/~a" symbol arity))))
(defun make-= (x y)
`(= ,x ,y))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *predicate* nil
"The Prolog predicate currently being compiled.")
(defun compile-predicate (symbol arity clauses)
"Compile all the CLAUSES for a given SYMBOL/ARITY into a single LISP function."
(let* ((*predicate* (make-predicate symbol arity))
(parameters (make-parameters arity))
(tree `(defun ,*predicate* (,@parameters cont)
.,(maybe-add-undo-bindings
(mapcar #'(lambda (clause)
(compile-clause parameters clause 'cont))
clauses)))))
(format *debug-io* "~&~a~%" tree)
;; https://stackoverflow.com/questions/46656090/sbcl-muffle-style-warning-in-defmacro
(declaim
#+sbcl
(sb-ext:muffle-conditions warning))
(compile (eval tree))))
(defun maybe-add-undo-bindings (compiled-exps)
"Undo any bindings that need undoing.
If there are any, bind the trail before we start."
(if (length=1 compiled-exps)
compiled-exps
`((let ((old-trail (fill-pointer *trail*)))
,(first compiled-exps)
,@(loop for exp in (rest compiled-exps)
collect `(undo-bindings! old-trail)
collect exp)))))
(defun compile-clause (parms clause cont)
"Transform away the head, and compile the resulting body."
(bind-unbound-vars
parms
(compile-body
(nconc
(mapcar #'make-= parms (args (clause-head clause)))
(clause-body clause))
cont
(mapcar #'self-cons parms))))
;;; See compiler-macro.lisp
(defun prolog-compiler-macro (name)
"Fetch the compiler macro for a Prolog predicate."
;; Note NAME is the raw name, not the NAME/ARITY
(get name 'prolog-compiler-macro))
(defun compile-body (body cont bindings)
"Compile the body of a clause."
(cond
((null body)
`(funcall ,cont))
((eq (first body) '!)
`(progn ,(compile-body (rest body) cont bindings)
(return-from ,*predicate* nil)))
(t (let* ((goal (first body))
(macro (prolog-compiler-macro (predicate goal)))
(macro-val (if macro
(funcall macro goal (rest body)
cont bindings))))
(if (and macro
(not (eq macro-val :pass)))
macro-val
`(,(make-predicate (predicate goal)
(relation-arity goal))
,@(mapcar #'(lambda (arg)
(compile-arg arg bindings))
(args goal))
,(if (null (rest body))
cont
`#'(lambda ()
,(compile-body
(rest body) cont
(bind-new-variables bindings goal))))))))))
(defun bind-new-variables (bindings goal)
"Extend BINDINGS to include any unbound variables in GOAL."
(let ((variables (remove-if #'(lambda (v) (assoc v bindings))
(variables-in goal))))
(nconc (mapcar #'self-cons variables) bindings)))
(defun compile-unify (x y bindings)
"Return 2 values: code to test if X and Y unify, and a new binding list."
(cond
;; Unify constants and conses:
((not (or (has-variable-p x)
(has-variable-p y)))
(values (equal x y) bindings))
((and (consp x)
(consp y))
(multiple-value-bind (code1 bindings1)
(compile-unify (first x) (first y) bindings)
(multiple-value-bind (code2 bindings2)
(compile-unify (rest x) (rest y) bindings1)
(values (compile-if code1 code2) bindings2))))
;; Here X or Y is a variable. Pick the right one:
((variable-p x) (compile-unify-variable x y bindings))
(t (compile-unify-variable y x bindings))))
(defun compile-unify-variable (x y bindings)
"X is a variable, and Y may be."
(let* ((xb (follow-binding x bindings))
(x1 (if xb (cdr xb) x))
(yb (if (variable-p y) (follow-binding y bindings)))
(y1 (if yb (cdr yb) y)))
(cond
((or (eq x '?) (eq y '?)) (values t bindings))
((not (and (equal x x1) (equal y y1)))
(compile-unify x1 y1 bindings))
((find-anywhere x1 y1)
(values nil bindings))
((consp y1)
(values `(unify! ,x1 ,(compile-arg y1 bindings))
(bind-variables-in y1 bindings)))
((not (null xb))
;; i.e. X is an ?ARG variable
(if (and (variable-p y1) (null yb))
(values 't (extend-bindings y1 x1 bindings))
(values `(unify! ,x1 ,(compile-arg y1 bindings))
(extend-bindings x1 y1 bindings))))
((not (null yb))
(compile-unify-variable y1 x1 bindings))
(t (values 't (extend-bindings x1 y1 bindings))))))
(defun bind-variables-in (exp bindings)
"Bind all variables in EXP to themselves, and add that to BINDINGS (except for variables already bound)."
(dolist (var (variables-in exp))
(unless (get-binding var bindings)
(setf bindings (extend-bindings var var bindings))))
bindings)
(defun follow-binding (var bindings)
"Get the ultimate binding of VAR according to BINDINGS."
(let ((b (get-binding var bindings)))
(if (eq (car b)
(cdr b))
b
(or (follow-binding (cdr b) bindings)
b))))
(defun compile-if (pred then-part)
"Compile a Lisp IF form. No else-part allowed."
(case pred
((t) then-part)
((nil) nil)
(otherwise `(if ,pred ,then-part))))
(defun compile-arg (arg bindings)
"Generate code for an argument to a goal in the body."
(cond ((eq arg '?) `(?))
((variable-p arg)
(let ((binding (get-binding arg bindings)))
(if (and (not (null binding))
(not (eq arg (binding-val binding))))
(compile-arg (binding-val binding) bindings)
arg)))
((not (find-if-anywhere #'variable-p arg)) `',arg)
((proper-listp arg)
`(list .,(mapcar #'(lambda (a) (compile-arg a bindings))
arg)))
(t `(cons ,(compile-arg (first arg) bindings)
,(compile-arg (rest arg) bindings)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun show-prolog-vars (vars bindings other-goals)
"Print each variable with its binding."
(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)))
;; XXX TODO?
(setf (get 'show-prolog-vars 'clauses) 'show-prolog-vars)
(defun show-prolog-vars/2 (var-names vars cont)
"Display the variables, and prompt the user to see if we should continue. If not, return to the top level."
(if (null vars)
(format t "~&Yes")
(loop for name in var-names
for var in vars do
(format t "~&~a = ~a" name (deref-exp var))))
(if (continue-p)
(funcall cont)
(throw 'top-level-prove nil)))
(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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun top-level-prove (goals)
"Prove the goals, and print variables readably."
;; First redefine top-level-query
(clear-predicate 'top-level-query)
(let ((vars (delete '? (variables-in goals))))
(add-clause `((top-level-query)
,@goals
(show-prolog-vars ,(mapcar #'symbol-name vars)
,vars))))
(run-prolog 'top-level-query/0 #'prolog/ignore)
(format t "~&No.")
(values))
;;; Lock on package COMMON-LISP violated when
;;; defining IGNORE as a function while in package CL-PROLOG.
;;; [Condition of type SB-EXT:SYMBOL-PACKAGE-LOCKED-ERROR]
(defun prolog/ignore (&rest args)
"Do nothing, return NIL."
;; Unrecognized declaration IGNORE? wtf.
(list args)
nil)
(defun run-prolog (procedure cont)
"Run a 0-ary prolog procedure with a given continuation."
;; First compile anythingn else that needs it
(prolog-compile-symbols)
;; Reset the trail and the new variable counter
(setf (fill-pointer *trail*) 0
*var-counter* 0)
;; Finally, call the query
(catch 'top-level-prove
(funcall procedure cont)))
(defun prolog-compile-symbols (&optional (symbols *uncompiled*))
"Compile a list of Prolog symbols. By default, the list is all symbols that need it."
(mapc #'prolog-compile symbols)
(setf *uncompiled* (set-difference *uncompiled* symbols)))

15
src/constants.lisp Normal file
View File

@ -0,0 +1,15 @@
(in-package #:cl-prolog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *occurs-check* t
"Should we do the occurs check?")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconstant fail nil
"Indicates UNIFY failure.")
(defvar no-bindings '((t . t))
"Indicates UNIFY success, with no variables.")
(defvar unbound "Unbound")

70
src/destructive-unify.lisp Normal file
View File

@ -0,0 +1,70 @@
(in-package #:cl-prolog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pg 379
(defvar *trail* (make-array 200 :fill-pointer 0 :adjustable t))
(defvar *var-counter* 0)
(defstruct (var (:constructor ? ())
(:print-function print-var))
(name (incf *var-counter*))
(binding unbound))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro deref (exp)
"Follow pointers for bound variables."
`(progn (loop while (and (var-p ,exp)
(bound-p ,exp))
do (setf ,exp (var-binding, exp)))
,exp))
(defun deref-exp (exp)
"Build something equivalent to EXP with variables dereferenced."
(if (atom (deref exp))
exp
(reuse-cons
(deref-exp (first exp))
(deref-exp (rest exp))
exp)))
(defun deref-copy (exp)
"Copy the expression, replacing variables with new ones.
The part without variables can be returned as is."
(sublis (mapcar #'(lambda (var) (cons (deref var) (?)))
(unique-find-anywhere-if #'var-p exp))
exp))
(defun print-var (var stream depth)
(if (or (and (numberp *print-level*)
(>= depth *print-level*))
(var-p (deref var)))
(format stream "?~a" (var-name var))
(write var :stream stream)))
(defun bound-p (var)
(not (eq (var-binding var) unbound)))
(defun unify! (x y)
"Destructively unify two expressions."
(cond ((eql (deref x) (deref y)) t)
((var-p x) (set-binding! x y))
((var-p y) (set-binding! y x))
((and (consp x) (consp y))
(and (unify! (first x) (first y))
(unify! (rest x) (rest y))))
(t nil)))
(defun set-binding! (var value)
"Set VAR's binding to VALUE, after saving the variable in the
*TRAIL*. Always succeeds (returns T)."
(unless (eq var value)
(vector-push-extend var *trail*)
(setf (var-binding var) value))
t)
(defun undo-bindings! (old-trail)
"Undo all bindings back to a given point in the trail."
(loop until (= (fill-pointer *trail*) old-trail)
do (setf (var-binding (vector-pop *trail*)) unbound)))

115
src/interp.lisp Normal file
View File

@ -0,0 +1,115 @@
(in-package #:cl-prolog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *db-predicates* nil
"A list of all predicates stored in the database.")
(defvar *uncompiled* nil
"Prolog symbols that have not been compiled.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun clause-head (clause)
(first clause))
(defun clause-body (clause)
(rest clause))
(defun get-clauses (pred)
(get pred 'clauses))
(defun predicate (relation)
(first relation))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro <- (&rest clause)
"Add a clause to the data base."
`(add-clause ',(make-anonymous clause)))
(defun make-anonymous (exp &optional (anon-vars (anonymous-variables-in exp)))
"Replace variables that are only used once with ?."
(cond ((consp exp)
(reuse-cons (make-anonymous (first exp) anon-vars)
(make-anonymous (rest exp) anon-vars)
exp))
((member exp anon-vars) `?)
(t exp)))
(defun anonymous-variables-in (tree)
"Return a list of all variables that occur only once in tree."
(values (anon-vars-in tree nil nil)))
(defun anon-vars-in (tree seen-once seen-more)
"Walk the data structure TREE, returning a list of variables seen once, and a list of variables seen more than once."
(cond ((consp tree)
(multiple-value-bind (new-seen-once new-seen-more)
(anon-vars-in (first tree) seen-once seen-more)
(anon-vars-in (rest tree) new-seen-once new-seen-more)))
((not (variable-p tree))
(values seen-once seen-more))
((member tree seen-once)
(values (delete tree seen-once)
(cons tree seen-more)))
((member tree seen-more)
(values seen-once seen-more))
(t (values (cons tree seen-once) seen-more))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro ?- (&rest goals)
"Make a query and print answers."
`(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 add-clause (clause)
"Add a CLAUSE to the data base, indexed by head's predicate."
;; The predicate must be a non-variable symbol.
(let ((pred (predicate (clause-head clause))))
(assert (and (symbolp pred)
(not (variable-p pred))))
(pushnew pred *db-predicates*)
(pushnew pred *uncompiled*)
(setf (get pred 'clauses)
(nconc (get-clauses pred) (list clause)))
pred))
(defun clear-db ()
"Remove all clauses (for all predicates) from the data base."
(mapc #'clear-predicate *db-predicates*))
(defun clear-predicate (predicate)
"Remove the clauses for a single predicate."
(setf (get predicate 'clauses) nil))
(defun prove-all (goals bindings)
"Return a list of solutions ot the conjunction of goals."
(cond ((eq bindings fail) fail)
((null goals) (list bindings))
(t (prove (first goals) bindings (rest goals)))))
(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))))
(defun rename-variables (x)
"Replace all variables in X with new ones."
(sublis (mapcar #'(lambda (var)
(cons var (gensym (string var))))
(variables-in x))
x))

8
src/package.lisp Normal file
View File

@ -0,0 +1,8 @@
(in-package #:cl-user)
(defpackage #:cl-prolog
(:use #:cl)
(:export #:main)
(:shadow #:ignore))
(in-package #:cl-prolog)

44
src/primitives.lisp Normal file
View File

@ -0,0 +1,44 @@
(in-package #:cl-prolog)
(defun read/1 (exp cont)
(if (unify! exp (read))
(funcall cont)))
(defun write/1 (exp cont)
(write (deref-exp exp) :pretty t)
(funcall cont))
(defun nl/0 (cont)
(terpri)
(funcall cont))
(defun =/2 (?arg1 ?arg2 cont)
(if (unify! ?arg1 ?arg2)
(funcall cont)))
(defun deref-equal (x y)
"Are the two arguments EQUAL with no unification, but with dereferencing?"
(or (eql (deref x) (deref y))
(and (consp x)
(consp y)
(deref-equal (first x) (first y))
(deref-equal (rest x) (rest y)))))
(defun call/1 (goal cont)
"Try to prove GOAL by calling it."
(deref goal)
(apply (make-predicate (first goal)
(length (args goal)))
(append (args goal) (list cont))))
(defun bagof/3 (exp goal result cont)
"Find all solutions to GOAL, and for each solution,
collect the value of EXP into the list RESULT."
;; Ex: Assume (p 1) (p 2) (p 3). Then:
;: (bagof ?x (p ?x) ?1) => ?1 = (1 2 3)
(let ((answers nil))
(call/1 goal #'(lambda ()
(push (deref-copy exp) answers)))
(if (and (not (null answers))
(unify! result (nreverse answers)))
(funcall cont))))

79
src/script.pro Normal file
View File

@ -0,0 +1,79 @@
;; 1.
(<- (likes Kim Robin))
(<- (likes Sandy Lee))
(<- (likes Sandy Kim))
(<- (likes Robin cats))
(<- (likes Sandy ?x) (likes ?x cats))
(<- (likes Kim ?x) (likes ?x Lee) (likes ?x Kim))
(<- (likes ?x ?y))
(?- (likes Sandy ?who))
;; (((?WHO . LEE)) ((?WHO . KIM)) ((#:?X292 . ROBIN) (?WHO . #:?X292))
;; ((#:?Y297 . CATS) (#:?X296 . CATS) (#:?X293 . CATS) (#:?X292 . SANDY)
;; (?WHO . #:?X292))
;; ((#:?Y306 . KIM) (#:?X305 . CATS) (#:?Y302 . LEE) (#:?X301 . CATS)
;; (#:?X298 . CATS) (#:?X292 . KIM) (?WHO . #:?X292))
;; ((#:?Y308 . CATS) (#:?X292 . #:?X307) (?WHO . #:?X292))
;; ((?WHO . #:?Y311) (#:?X310 . SANDY)))
(<- (member ?item (?item . ?)))
(<- (member ?item (? . ?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)
(= ?h ((house norwegian ? ? ? ?)
?
(house ? ? ? milk ?) ? ?))
(member (house englishman ? ? ? red) ?h)
(member (house spaniard dog ? ? ?) ?h)
(member (house ? ? ? coffee green) ?h)
(member (house ukrainian ? ? tea ?) ?h)
(member (house ? ? ? ? ivory) ?h)
(iright (house ? ? ? ? ivory)
(house ? ? ? ? green) ?h)
(member (house ? snails winston ? ?) ?h)
(member (house ? ? kools ? yellow) ?h)
(nextto (house ? ? chesterfield ? ?)
(house ? fox ? ? ?) ?h)
(nextto (house ? ? kools ? ?)
(house ? horse ? ? ?) ?h)
(member (house ? ? luckystrike orange-juice ?) ?h)
(member (house japanese ? parliaments ? ?) ?h)
(nextto (house norwegian ? ? ? ?)
(house ? ? ? ? blue) ?h)
(member (house ?w ? ? water ?) ?h)
(member (house ?z zebra ? ? ?) ?h))
(?- (zebra ?houses ?water-drinker ?zebra-owner))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pg 380
(<- (prove ?goal) (prove-all (?goal)))
(<- (prove-all nil))
(<- (prove-all (?goal . ?goals))
(clause (<- ?goal . ?body))
(concat ?body ?goals ?new-goals)
(prove-all ?new-goals))
(<- (clause <- (mem (? (?x . ?y)))))
(<- (clause (<- (mem ?x (? . ?z)) (mem ?x ?z))))
(?- (prove (mem ?x (1 2 3))))
(<- (rev () ()))
(<- (rev (?x . ?a) ?b) (rev ?a ?c) (concat ?c (?x) ?b))
(<- (concat () ?l ?l))
(<- (concat (?x . ?a) ?b (?x . ?c)) (concat ?a ?b ?c))
(<- (irev ?l ?r) (irev3 ?l () ?r))
(<- (irev3 (?x . ?l) ?so-far ?r) (irev3 ?l (?x . ?so-far) ?r))
(<- (irev3 () ?r ?r))

46
src/unify.lisp Normal file
View File

@ -0,0 +1,46 @@
(in-package #:cl-prolog)
;;; -*- Mode: Lisp; Syntax: Common-Lisp; -*-
;;; Code from Paradigms of Artificial Intelligence Programming
;;; Copyright (c) 1991 Peter Norvig
;;;; File unify.lisp: Unification functions
(defparameter *occurs-check* t
"Should we do the occurs check?")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun unify (x y &optional (bindings no-bindings))
"See if x and y match with given bindings."
(cond ((eq bindings fail) fail)
((eql x y) bindings)
((variable-p x) (unify-variable x y bindings))
((variable-p y) (unify-variable y x bindings))
((and (consp x) (consp y))
(unify (rest x) (rest y)
(unify (first x) (first y) bindings)))
(t fail)))
(defun unify-variable (var x bindings)
"Unify var with x, using (and maybe extending) bindings."
(cond ((get-binding var bindings)
(unify (lookup var bindings) x bindings))
((and (variable-p x) (get-binding x bindings))
(unify var (lookup x bindings) bindings))
((and *occurs-check* (occurs-check var x bindings))
fail)
(t (extend-bindings var x bindings))))
(defun occurs-check (var x bindings)
"Does VAR occur anywhere inside X?"
(cond ((eq var x) t)
((and (variable-p x) (get-binding x bindings))
(occurs-check var (lookup x bindings) bindings))
((consp x) (or (occurs-check var (first x) bindings)
(occurs-check var (rest x) bindings)))
(t nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun unifier (x y)
"Return something that unifies with both X and Y (or FAIL)."
(subst-bindings (unify x y) x))

70
src/utils.lisp Normal file
View File

@ -0,0 +1,70 @@
(in-package #:cl-prolog)
;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;; Code from Paradigms of AI Programming
;;; Copyright (c) 1991 Peter Norvig
;;; File auxfns.lisp: Auxiliary functions used by all other programs
;;; Load this file before running any other programs.
(declaim (inline find-all))
(defun find-all (item sequence &rest keyword-args
&key (test #'eql) test-not &allow-other-keys)
"Find all those elements of sequence that match item,
according to the keywords. Doesn't alter sequence."
(if test-not
(apply #'remove item sequence
:test-not (complement test-not) keyword-args)
(apply #'remove item sequence
:test (complement test) keyword-args)))
(defun unique-find-anywhere-if (predicate tree &optional found-so-far)
"Return a list of leaves of TREE satisfying PREDICATE, with duplicates removed."
(if (atom tree)
(if (funcall predicate tree)
(adjoin tree found-so-far)
found-so-far)
(unique-find-anywhere-if
predicate
(first tree)
(unique-find-anywhere-if predicate (rest tree)
found-so-far))))
(defun find-if-anywhere (predicate tree)
"Does PREDICATE apply to any atom in the TREE?"
(if (atom tree)
(funcall predicate tree)
(or (find-if-anywhere predicate (first tree))
(find-if-anywhere predicate (rest tree)))))
(defun find-anywhere (item tree)
"Does ITEM occur anywhere in TREE?"
(if (atom tree)
(if (eql item tree)
tree)
(or (find-anywhere item (first tree))
(find-anywhere item (rest tree)))))
(declaim (inline length=1))
(defun length=1 (x)
"Is X a list of length 1?"
(and (consp x)
(null (cdr x))))
(declaim (inline reuse-cons))
(defun reuse-cons (x y x-y)
"Return (CONS X Y), or just X-Y if it is equal to (CONS X Y)."
(if (and (eql x (car x-y))
(eql y (cdr x-y)))
x-y
(cons x y)))
(declaim (inline self-cons))
(defun self-cons (x)
(cons x x))
(defun proper-listp (x)
"Is X a proper (non-dotted) list?"
(or (null x)
(and (consp x)
(proper-listp (rest x)))))

20
systems.csv Normal file
View File

@ -0,0 +1,20 @@
deploy, ghcr.io/ocicl/deploy@sha256:e08c14d46ca07126e19a447b27d948dfa2de2ee9ed9bd9e4d106db08990bb716, deploy-20240824-f9b41f3/deploy.asd
deploy-test, ghcr.io/ocicl/deploy@sha256:e08c14d46ca07126e19a447b27d948dfa2de2ee9ed9bd9e4d106db08990bb716, deploy-20240824-f9b41f3/deploy-test.asd
uffi, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/uffi-compat/uffi.asd
cffi, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/cffi.asd
cffi-uffi-compat, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/cffi-uffi-compat.asd
cffi-toolchain, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/cffi-toolchain.asd
cffi-tests, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/cffi-tests.asd
cffi-libffi, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/cffi-libffi.asd
cffi-grovel, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/cffi-grovel.asd
cffi-examples, ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742, cffi-20240811-32c90d4/cffi-examples.asd
alexandria, ghcr.io/ocicl/alexandria@sha256:e433c2e076ed3bcf8641b97b00192680db2201d305efac9293539dee88c7fbf7, alexandria-20240503-8514d8e/alexandria.asd
trivial-features, ghcr.io/ocicl/trivial-features@sha256:e278e24d39060fc7d3715531b16ddd9ab7f93f22ade53e436c0b86dbae3aa065, trivial-features-1.0/trivial-features.asd
trivial-features-tests, ghcr.io/ocicl/trivial-features@sha256:e278e24d39060fc7d3715531b16ddd9ab7f93f22ade53e436c0b86dbae3aa065, trivial-features-1.0/trivial-features-tests.asd
babel, ghcr.io/ocicl/babel@sha256:b505136744213e6b953913780a4b647da40e83818a10f41004846863b5037810, babel-20240606-23c1440/babel.asd
babel-tests, ghcr.io/ocicl/babel@sha256:b505136744213e6b953913780a4b647da40e83818a10f41004846863b5037810, babel-20240606-23c1440/babel-tests.asd
babel-streams, ghcr.io/ocicl/babel@sha256:b505136744213e6b953913780a4b647da40e83818a10f41004846863b5037810, babel-20240606-23c1440/babel-streams.asd
sha3, ghcr.io/ocicl/sha3@sha256:556fcc3d3fcba08185de62f7bb090fa233af4f8c68a4d7401992a32e03fb9a70, sha3-20240503-a4baa05/sha3.asd
multilang-documentation-utils, ghcr.io/ocicl/documentation-utils@sha256:b2a1b3f3bcd1a738af85ae2b0168d408c177661eab6d6bbebb254e394d983f54, documentation-utils-20230511-98630dd/multilang-documentation-utils.asd
documentation-utils, ghcr.io/ocicl/documentation-utils@sha256:b2a1b3f3bcd1a738af85ae2b0168d408c177661eab6d6bbebb254e394d983f54, documentation-utils-20230511-98630dd/documentation-utils.asd
trivial-indent, ghcr.io/ocicl/trivial-indent@sha256:f1ae624eb2ca37133912e9920587488ea6e2f1d6419ba4a1776e63c2bdff0fd9, trivial-indent-20240503-b5d490f/trivial-indent.asd
1 deploy ghcr.io/ocicl/deploy@sha256:e08c14d46ca07126e19a447b27d948dfa2de2ee9ed9bd9e4d106db08990bb716 deploy-20240824-f9b41f3/deploy.asd
2 deploy-test ghcr.io/ocicl/deploy@sha256:e08c14d46ca07126e19a447b27d948dfa2de2ee9ed9bd9e4d106db08990bb716 deploy-20240824-f9b41f3/deploy-test.asd
3 uffi ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/uffi-compat/uffi.asd
4 cffi ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/cffi.asd
5 cffi-uffi-compat ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/cffi-uffi-compat.asd
6 cffi-toolchain ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/cffi-toolchain.asd
7 cffi-tests ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/cffi-tests.asd
8 cffi-libffi ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/cffi-libffi.asd
9 cffi-grovel ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/cffi-grovel.asd
10 cffi-examples ghcr.io/ocicl/cffi@sha256:fe1246d11c4c067daefdb143e1252e0f3e99046909185d2c920adb8323318742 cffi-20240811-32c90d4/cffi-examples.asd
11 alexandria ghcr.io/ocicl/alexandria@sha256:e433c2e076ed3bcf8641b97b00192680db2201d305efac9293539dee88c7fbf7 alexandria-20240503-8514d8e/alexandria.asd
12 trivial-features ghcr.io/ocicl/trivial-features@sha256:e278e24d39060fc7d3715531b16ddd9ab7f93f22ade53e436c0b86dbae3aa065 trivial-features-1.0/trivial-features.asd
13 trivial-features-tests ghcr.io/ocicl/trivial-features@sha256:e278e24d39060fc7d3715531b16ddd9ab7f93f22ade53e436c0b86dbae3aa065 trivial-features-1.0/trivial-features-tests.asd
14 babel ghcr.io/ocicl/babel@sha256:b505136744213e6b953913780a4b647da40e83818a10f41004846863b5037810 babel-20240606-23c1440/babel.asd
15 babel-tests ghcr.io/ocicl/babel@sha256:b505136744213e6b953913780a4b647da40e83818a10f41004846863b5037810 babel-20240606-23c1440/babel-tests.asd
16 babel-streams ghcr.io/ocicl/babel@sha256:b505136744213e6b953913780a4b647da40e83818a10f41004846863b5037810 babel-20240606-23c1440/babel-streams.asd
17 sha3 ghcr.io/ocicl/sha3@sha256:556fcc3d3fcba08185de62f7bb090fa233af4f8c68a4d7401992a32e03fb9a70 sha3-20240503-a4baa05/sha3.asd
18 multilang-documentation-utils ghcr.io/ocicl/documentation-utils@sha256:b2a1b3f3bcd1a738af85ae2b0168d408c177661eab6d6bbebb254e394d983f54 documentation-utils-20230511-98630dd/multilang-documentation-utils.asd
19 documentation-utils ghcr.io/ocicl/documentation-utils@sha256:b2a1b3f3bcd1a738af85ae2b0168d408c177661eab6d6bbebb254e394d983f54 documentation-utils-20230511-98630dd/documentation-utils.asd
20 trivial-indent ghcr.io/ocicl/trivial-indent@sha256:f1ae624eb2ca37133912e9920587488ea6e2f1d6419ba4a1776e63c2bdff0fd9 trivial-indent-20240503-b5d490f/trivial-indent.asd