Finish basic proving
I gave up on making the renameless unification work because I'm just too dumb to
understand it. Gonna throw this all away when I hit the WAM book anyhow, so
it's not worth wasting time on. Maybe I'll come back to it later if I have
time.
author |
Steve Losh <steve@stevelosh.com> |
date |
Thu, 10 Mar 2016 18:22:56 +0000 |
parents |
49191daa42d0 |
children |
f57121ef4229 |
;;;; This file was automatically generated by Quickutil.
;;;; See http://quickutil.org for details.
;;;; To regenerate:
;;;; (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")
(defpackage "BONES.UTILS"
(:documentation "Package that contains Quickutil utility functions.")
(:use #:cl))))
(in-package "BONES.UTILS")
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL
:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:CURRY))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
value
(let ((old (symbol-value name))
(new value))
(if (not (constantp name))
(prog1 new
(cerror "Try to redefine the variable as a constant."
"~@<~S is an already bound non-constant variable ~
whose value is ~S.~:@>" name old))
(if (funcall test old new)
old
(restart-case
(error "~@<~S is an already defined constant whose value ~
~S is not equal to the provided initial value ~S ~
under ~S.~:@>" name old new test)
(ignore ()
:report "Retain the current value."
old)
(continue ()
:report "Try to redefine the constant."
new)))))))
(defmacro define-constant (name initial-value &key (test ''eql) documentation)
"Ensures that the global variable named by `name` is a constant with a value
that is equal under `test` to the result of evaluating `initial-value`. `test` is a
function designator that defaults to `eql`. If `documentation` is given, it
becomes the documentation string of the constant.
Signals an error if `name` is already a bound non-constant variable.
Signals an error if `name` is already a constant variable whose value is not
equal under `test` to result of evaluating `initial-value`."
`(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
,@(when documentation `(,documentation))))
(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
"Returns true if every element of `list1` matches some element of `list2` and
every element of `list2` matches some element of `list1`. Otherwise returns false."
(let ((keylist1 (if keyp (mapcar key list1) list1))
(keylist2 (if keyp (mapcar key list2) list2)))
(and (dolist (elt keylist1 t)
(or (member elt keylist2 :test test)
(return nil)))
(dolist (elt keylist2 t)
(or (member elt keylist1 :test test)
(return nil))))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(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 ;;;;