commit b71f692fef16a64495659bfbc07c248b23fec55b
Author: Bubblegumdrop <staticsunn@gmail.com>
Date:   Sat Sep 21 20:43:41 2024 -0400

    Initial commit for git.lain.church

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..1af7b60
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+*.fasl
+bin/
+systems/
diff --git a/cl-prolog.asd b/cl-prolog.asd
new file mode 100644
index 0000000..b46fc57
--- /dev/null
+++ b/cl-prolog.asd
@@ -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))
diff --git a/readme.org b/readme.org
new file mode 100644
index 0000000..51d9be6
--- /dev/null
+++ b/readme.org
@@ -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.
diff --git a/src/bindings.lisp b/src/bindings.lisp
new file mode 100644
index 0000000..4cb1832
--- /dev/null
+++ b/src/bindings.lisp
@@ -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))))
diff --git a/src/cl-prolog.lisp b/src/cl-prolog.lisp
new file mode 100644
index 0000000..118f698
--- /dev/null
+++ b/src/cl-prolog.lisp
@@ -0,0 +1,4 @@
+(in-package #:cl-prolog)
+
+(defun main ()
+  )
diff --git a/src/compiler-macro.lisp b/src/compiler-macro.lisp
new file mode 100644
index 0000000..72e4fde
--- /dev/null
+++ b/src/compiler-macro.lisp
@@ -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)))))))))
diff --git a/src/compiler.lisp b/src/compiler.lisp
new file mode 100644
index 0000000..2d4aa5c
--- /dev/null
+++ b/src/compiler.lisp
@@ -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)))
diff --git a/src/constants.lisp b/src/constants.lisp
new file mode 100644
index 0000000..fbf7e1b
--- /dev/null
+++ b/src/constants.lisp
@@ -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")
+
diff --git a/src/destructive-unify.lisp b/src/destructive-unify.lisp
new file mode 100644
index 0000000..7c98d38
--- /dev/null
+++ b/src/destructive-unify.lisp
@@ -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)))
diff --git a/src/interp.lisp b/src/interp.lisp
new file mode 100644
index 0000000..48da8a4
--- /dev/null
+++ b/src/interp.lisp
@@ -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))
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..2c756d6
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,8 @@
+(in-package #:cl-user)
+
+(defpackage #:cl-prolog
+  (:use #:cl)
+  (:export #:main)
+  (:shadow #:ignore))
+
+(in-package #:cl-prolog)
diff --git a/src/primitives.lisp b/src/primitives.lisp
new file mode 100644
index 0000000..14f3edb
--- /dev/null
+++ b/src/primitives.lisp
@@ -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))))
diff --git a/src/script.pro b/src/script.pro
new file mode 100644
index 0000000..eee8506
--- /dev/null
+++ b/src/script.pro
@@ -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))
diff --git a/src/unify.lisp b/src/unify.lisp
new file mode 100644
index 0000000..f16f846
--- /dev/null
+++ b/src/unify.lisp
@@ -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))
diff --git a/src/utils.lisp b/src/utils.lisp
new file mode 100644
index 0000000..1c0ae42
--- /dev/null
+++ b/src/utils.lisp
@@ -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)))))
diff --git a/systems.csv b/systems.csv
new file mode 100644
index 0000000..b83f1e4
--- /dev/null
+++ b/systems.csv
@@ -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