--- a/src/paip-compiled.lisp Tue Mar 22 14:31:35 2016 +0000
+++ b/src/paip-compiled.lisp Tue Mar 22 16:46:29 2016 +0000
@@ -1,5 +1,36 @@
(in-package #:bones.paip)
+;;;; Utils
+(defun find-all (item sequence
+ &rest keyword-args
+ &key (test #'eql) test-not &allow-other-keys)
+ "Find all elements of the sequence that match the item.
+
+ Does not alter the 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 interned-symbol (&rest args)
+ (intern (format nil "~{~A~}" args)))
+
+(defun new-symbol (&rest args)
+ (make-symbol (format nil "~{~A~}" args)))
+
+(defun find-if-anywhere (test expr)
+ (cond ((funcall test expr) t)
+ ((consp expr) (or (find-if-anywhere test (car expr))
+ (find-if-anywhere test (cdr expr))))
+ (t nil)))
+
+
+;;;; UNIFICATION --------------------------------------------------------------
;;;; Variables
(define-constant unbound "Unbound"
:test #'equal
@@ -84,3 +115,185 @@
;; Otherwise they don't unify.
(t nil)))
+
+
+;;;; COMPILATION --------------------------------------------------------------
+(deftype relation ()
+ 'list)
+
+(deftype clause ()
+ '(trivial-types:proper-list relation))
+
+(deftype non-negative-integer ()
+ '(integer 0))
+
+
+(defun prolog-compile (symbol &optional (clauses (get-clauses symbol)))
+ "Compile a symbol; make a separate function for each arity."
+ (when (not (null clauses))
+ (let* ((arity (relation-arity (clause-head (first clauses))))
+ (matching-arity-clauses (clauses-with-arity clauses #'= arity))
+ (other-arity-clauses (clauses-with-arity clauses #'/= arity)))
+ (compile-predicate symbol arity matching-arity-clauses)
+ (prolog-compile symbol other-arity-clauses))))
+
+(defun* clauses-with-arity
+ ((clauses (trivial-types:proper-list clause))
+ (test function)
+ (arity non-negative-integer))
+ "Return all clauses whose heads have the given arity."
+ (find-all arity clauses
+ :key #'(lambda (clause)
+ (relation-arity (clause-head clause)))
+ :test test))
+
+
+(defun* relation-arity ((relation relation))
+ (:returns non-negative-integer)
+ "Return the number of arguments of the given relation.
+
+ For example: `(relation-arity '(likes sally cats))` => `2`
+
+ "
+ (length (relation-arguments relation)))
+
+(defun* relation-arguments ((relation relation))
+ (:returns list)
+ "Return the arguments of the given relation.
+
+ For example:
+
+ * (relation-arguments '(likes sally cats))
+ (sally cats)
+
+ "
+ (rest relation))
+
+
+(defun* compile-predicate
+ ((symbol symbol)
+ (arity non-negative-integer)
+ (clauses (trivial-types:proper-list clause)))
+ "Compile all the clauses for the symbol+arity into a single Lisp function."
+ (let ((predicate (make-predicate symbol arity))
+ (parameters (make-parameters arity)))
+ (compile
+ (eval
+ `(defun ,predicate (,@parameters continuation)
+ .,(maybe-add-undo-bindings
+ (mapcar #'(lambda (clause)
+ (compile-clause parameters clause 'continuation))
+ clauses)))))))
+
+(defun* make-parameters ((arity non-negative-integer))
+ (:returns (trivial-types:proper-list symbol))
+ "Return the list (?arg1 ?arg2 ... ?argN)."
+ (loop :for i :from 1 :to arity
+ :collect (new-symbol '?arg i)))
+
+(defun* make-predicate ((symbol symbol)
+ (arity non-negative-integer))
+ (:returns symbol)
+ "Returns (and interns) the symbol with the Prolog-style name symbol/arity."
+ (values (interned-symbol symbol '/ arity)))
+
+
+(defun make-= (x y)
+ `(= ,x ,y))
+
+(defun compile-clause (parameters clause continuation)
+ "Transform away the head and compile the resulting body."
+ (bind-unbound-vars
+ parameters
+ (compile-body
+ (nconc
+ (mapcar #'make-= parameters (relation-arguments (clause-head clause)))
+ (clause-body clause))
+ continuation)))
+
+(defun compile-body (body continuation)
+ "Compile the body of a clause."
+ (if (null body)
+ `(funcall ,continuation)
+ (let* ((goal (first body))
+ (macro (prolog-compiler-macro (predicate goal)))
+ (macro-val (when macro
+ (funcall macro goal (rest body) continuation))))
+ (if (and macro (not (eq macro-val :pass)))
+ macro-val
+ (compile-call
+ (make-predicate (predicate goal)
+ (relation-arity goal))
+ (mapcar #'(lambda (arg) (compile-arg arg))
+ (relation-arguments goal))
+ (if (null (rest body))
+ continuation
+ `#'(lambda ()
+ ,(compile-body (rest body) continuation))))))))
+
+(defun compile-call (predicate args continuation)
+ `(,predicate ,@args ,continuation))
+
+(defun prolog-compiler-macro (name)
+ "Fetch the compiler macro for a Prolog predicate."
+ (get name 'prolog-compiler-macro))
+
+(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 continuation)
+ (let ((args (relation-arguments goal)))
+ (if (/= (length args) 2)
+ :pass
+ `(when ,(compile-unify (first args) (second args))
+ ,(compile-body body continuation)))))
+
+(defun compile-unify (x y)
+ "Return code that tests if the items unify."
+ `(unify! ,(compile-arg x) ,(compile-arg y)))
+
+
+(defun compile-arg (arg)
+ "Generate code for an argument to a goal in the body."
+ (cond ((variable-p arg) arg)
+ ((not (has-variable-p arg)) `',arg)
+ ((proper-list-p arg)
+ `(list .,(mapcar #'compile-arg arg)))
+ (t `(cons ,(compile-arg (first arg))
+ ,(compile-arg (rest arg))))))
+
+(defun has-variable-p (x)
+ "Is there a variable anywhere in the expression x?"
+ (find-if-anywhere #'variable-p x))
+
+(defun proper-list-p (x)
+ "Is x a proper (non-dotted) list?"
+ (or (null x)
+ (and (consp x) (proper-list-p (rest x)))))
+
+
+(defun maybe-add-undo-bindings (compiled-expressions)
+ "Undo any bindings that need undoing.
+
+ If there ARE any, also bind the trail before we start.
+
+ "
+ (if (= (length compiled-expressions) 1)
+ compiled-expressions
+ `((let ((old-trail (fill-pointer *trail*)))
+ ,(first compiled-expressions)
+ ,@(loop :for expression :in (rest compiled-expressions)
+ :collect '(undo-bindings! old-trail)
+ :collect expression)))))
+
+(defun bind-unbound-vars (parameters expr)
+ "Bind any variables in expr (besides the parameters) to new vars."
+ (let ((expr-vars (set-difference (variables-in expr) parameters)))
+ (if expr-vars
+ `(let ,(mapcar #'(lambda (var) `(,var (?)))
+ expr-vars)
+ ,expr)
+ expr)))