49191daa42d0

--- a/src/make-utilities.lisp	Wed Mar 09 11:36:04 2016 +0000
+++ b/src/make-utilities.lisp	Wed Mar 09 11:48:07 2016 +0000
@@ -2,5 +2,6 @@
 
 (qtlc:save-utils-as "utils.lisp"
                     :utilities '(:define-constant
-                                 :set-equal)
+                                 :set-equal
+                                 :curry)
                     :package "BONES.UTILS")

--- a/src/paip.lisp	Wed Mar 09 11:36:04 2016 +0000
+++ b/src/paip.lisp	Wed Mar 09 11:48:07 2016 +0000
@@ -59,17 +59,6 @@
           nil
           bindings)))
 
-(defun* match-variable ((variable logic-variable)
-                        (input t)
-                        (bindings binding-list))
-  "Match the var with input, using (possibly updating) and returning bindings."
-  (let ((binding (get-binding variable bindings)))
-    (cond ((not binding)
-           (extend-bindings variable input bindings))
-          ((equal input (binding-value binding))
-           bindings)
-          (t fail))))
-
 (defun* check-occurs ((variable logic-variable)
                       (target t)
                       (bindings binding-list))
@@ -151,3 +140,19 @@
      (t fail))))
 
 
+;;;; Substitution
+(defun* substitute-bindings ((bindings binding-list)
+                             (form t))
+  "Substitute (recursively) the bindings into the given form."
+  (cond ((eq bindings fail) fail)
+        ((eq bindings no-bindings) form)
+        ((and (variable-p form) (get-binding form bindings))
+         (substitute-bindings bindings
+                              (lookup form bindings)))
+        ((listp form)
+         (mapcar (curry #'substitute-bindings bindings) form))
+        (t form)))
+
+(defun unifier (x y)
+  "Unify x with y and substitute in the bindings to get the result."
+  (substitute-bindings (unify x y) x))

--- a/src/utils.lisp	Wed Mar 09 11:36:04 2016 +0000
+++ b/src/utils.lisp	Wed Mar 09 11:48:07 2016 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL) :ensure-package T :package "BONES.UTILS")
+;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY) :ensure-package T :package "BONES.UTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "BONES.UTILS")
@@ -13,7 +13,9 @@
 (in-package "BONES.UTILS")
 
 (when (boundp '*utilities*)
-  (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL))))
+  (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL
+                                         :MAKE-GENSYM-LIST :ENSURE-FUNCTION
+                                         :CURRY))))
 
   (defun %reevaluate-constant (name value test)
     (if (not (boundp name))
@@ -65,6 +67,49 @@
                  (return nil))))))
   
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(define-constant set-equal)))
+  (defun make-gensym-list (length &optional (x "G"))
+    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+    (let ((g (if (typep x '(integer 0)) x (string x))))
+      (loop repeat length
+            collect (gensym g))))
+  )                                        ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;;; To propagate return type and allow the compiler to eliminate the IF when
+  ;;; it is known if the argument is function or not.
+  (declaim (inline ensure-function))
+
+  (declaim (ftype (function (t) (values function &optional))
+                  ensure-function))
+  (defun ensure-function (function-designator)
+    "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+    (if (functionp function-designator)
+        function-designator
+        (fdefinition function-designator)))
+  )                                        ; eval-when
+
+  (defun curry (function &rest arguments)
+    "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (let ((fn (ensure-function function)))
+      (lambda (&rest more)
+        (declare (dynamic-extent more))
+        ;; Using M-V-C we don't need to append the arguments.
+        (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+  (define-compiler-macro curry (function &rest arguments)
+    (let ((curries (make-gensym-list (length arguments) "CURRY"))
+          (fun (gensym "FUN")))
+      `(let ((,fun (ensure-function ,function))
+             ,@(mapcar #'list curries arguments))
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest more)
+           (apply ,fun ,@curries more)))))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(define-constant set-equal curry)))
 
 ;;;; END OF utils.lisp ;;;;