--- a/Makefile Mon Aug 08 23:59:49 2016 +0000
+++ b/Makefile Tue Aug 09 18:09:18 2016 +0000
@@ -2,7 +2,7 @@
lisps := $(shell ffind '\.(asd|lisp|ros)$$')
-vendor/quickutils.lisp: make-quickutils.lisp
+quickutils.lisp: make-quickutils.lisp
sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
build/silt: $(lisps)
@@ -10,6 +10,7 @@
update-deps:
hg -R /home/sjl/cl-losh pull -u
+ hg -R /home/sjl/beast pull -u
/opt/silt/silt: update-deps build/silt
rm /opt/silt/silt
--- a/make-quickutils.lisp Mon Aug 08 23:59:49 2016 +0000
+++ b/make-quickutils.lisp Tue Aug 09 18:09:18 2016 +0000
@@ -1,7 +1,7 @@
(ql:quickload 'quickutil)
(qtlc:save-utils-as
- "vendor/quickutils.lisp"
+ "quickutils.lisp"
:utilities '(
:with-gensyms
:once-only
--- a/package.lisp Mon Aug 08 23:59:49 2016 +0000
+++ b/package.lisp Tue Aug 09 18:09:18 2016 +0000
@@ -4,6 +4,7 @@
#:iterate
#:cl-arrows
#:losh
+ #:beast
#:silt.quickutils)
(:export
#:main))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/quickutils.lisp Tue Aug 09 18:09:18 2016 +0000
@@ -0,0 +1,322 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :PARSE-BODY :DEFINE-CONSTANT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT) :ensure-package T :package "SILT.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "SILT.QUICKUTILS")
+ (defpackage "SILT.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "SILT.QUICKUTILS")
+
+(when (boundp '*utilities*)
+ (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
+ :MAKE-GENSYM-LIST :ONCE-ONLY
+ :ENSURE-FUNCTION :COMPOSE :CURRY
+ :RCURRY :PARSE-BODY :DEFINE-CONSTANT
+ :HASH-TABLE-KEY-EXISTS-P :MAPHASH-KEYS
+ :HASH-TABLE-KEYS :MAPHASH-VALUES
+ :HASH-TABLE-VALUES :MAPPEND
+ :MAP-PRODUCT))))
+
+ (deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
+
+
+ (defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+ (defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(with-gensyms ,names ,@forms))
+
+(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
+
+ (defmacro once-only (specs &body forms)
+ "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+ (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+ (symbol symbol)
+
+Example:
+
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n)
+ ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+(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 compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
+ (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)))))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
+ (defun parse-body (body &key documentation whole)
+ "Parses `body` into `(values remaining-forms declarations doc-string)`.
+Documentation strings are recognized only if `documentation` is true.
+Syntax errors in body are signalled and `whole` is used in the signal
+arguments when given."
+ (let ((doc nil)
+ (decls nil)
+ (current nil))
+ (tagbody
+ :declarations
+ (setf current (car body))
+ (when (and documentation (stringp current) (cdr body))
+ (if doc
+ (error "Too many documentation strings in ~S." (or whole body))
+ (setf doc (pop body)))
+ (go :declarations))
+ (when (and (listp current) (eql (first current) 'declare))
+ (push (pop body) decls)
+ (go :declarations)))
+ (values body (nreverse decls) doc)))
+
+
+ (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 hash-table-key-exists-p (hash-table key)
+ "Does `key` exist in `hash-table`?"
+ (nth-value 1 (gethash key hash-table)))
+
+
+ (declaim (inline maphash-keys))
+ (defun maphash-keys (function table)
+ "Like `maphash`, but calls `function` with each key in the hash table `table`."
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (funcall function k))
+ table))
+
+
+ (defun hash-table-keys (table)
+ "Returns a list containing the keys of hash table `table`."
+ (let ((keys nil))
+ (maphash-keys (lambda (k)
+ (push k keys))
+ table)
+ keys))
+
+
+ (declaim (inline maphash-values))
+ (defun maphash-values (function table)
+ "Like `maphash`, but calls `function` with each value in the hash table `table`."
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (funcall function v))
+ table))
+
+
+ (defun hash-table-values (table)
+ "Returns a list containing the values of hash table `table`."
+ (let ((values nil))
+ (maphash-values (lambda (v)
+ (push v values))
+ table)
+ values))
+
+
+ (defun mappend (function &rest lists)
+ "Applies `function` to respective element(s) of each `list`, appending all the
+all the result list to a single list. `function` must return a list."
+ (loop for results in (apply #'mapcar function lists)
+ append results))
+
+
+ (defun map-product (function list &rest more-lists)
+ "Returns a list containing the results of calling `function` with one argument
+from `list`, and one from each of `more-lists` for each combination of arguments.
+In other words, returns the product of `list` and `more-lists` using `function`.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+ => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+ (2 3 5) (2 3 6) (2 4 5) (2 4 6))"
+ (labels ((%map-product (f lists)
+ (let ((more (cdr lists))
+ (one (car lists)))
+ (if (not more)
+ (mapcar f one)
+ (mappend (lambda (x)
+ (%map-product (curry f x) more))
+ one)))))
+ (%map-product (ensure-function function) (cons list more-lists))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(with-gensyms with-unique-names once-only compose curry rcurry
+ parse-body define-constant hash-table-key-exists-p hash-table-keys
+ hash-table-values map-product)))
+
+;;;; END OF quickutils.lisp ;;;;
--- a/silt.asd Mon Aug 08 23:59:49 2016 +0000
+++ b/silt.asd Tue Aug 09 18:09:18 2016 +0000
@@ -11,12 +11,10 @@
#:cl-charms
#:cl-arrows
#:sb-sprof
- #:losh)
+ #:losh
+ #:beast)
:serial t
- :components
- ((:module "vendor"
- :serial t
- :components ((:file "quickutils")))
- (:file "package")
- (:file "silt")))
+ :components ((:file "quickutils")
+ (:file "package")
+ (:file "silt")))
--- a/silt.lisp Mon Aug 08 23:59:49 2016 +0000
+++ b/silt.lisp Tue Aug 09 18:09:18 2016 +0000
@@ -388,173 +388,9 @@
(collect (random-elt *name-syllables*)))))
-;;;; Roll-Your-Own-ECS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Entities are stored in an {id -> entity} hash table.
-;;;
-;;; Entities are also indexed by component in a nested hash table:
-;;;
-;;; {component-symbol -> {id -> entity}}
-;;;
-;;; Entities are indexed by system too:
-;;;
-;;; {system-symbol ->
-;;; ({id -> entity} ; arg1
-;;; {id -> entity}) ; arg2
-;;; }
-;;;
-;;; Systems are stored as:
-;;;
-;;; {system-symbol -> (cons system-function type-specifier-list)}
-;;;
-;;; TODO: Figure out the distinct problem.
-;;; TODO: Unfuck redefining of systems.
-
-(defvar *entity-id-counter* 0)
-(defvar *entity-index* (make-hash-table))
-(defvar *component-index* (make-hash-table))
-(defvar *system-index* (make-hash-table))
-(defvar *systems* (make-hash-table))
-
-
-(defun get-entity (id)
- (gethash id *entity-index*))
-
-(defun map-entities (function &optional (type 'entity))
- (->> *entity-index*
- hash-table-values
- (remove-if-not (lambda (entity) (typep entity type)))
- (mapcar function)))
-
-(defun clear-entities ()
- (mapc #'destroy-entity (hash-table-values *entity-index*)))
-
-
-(defun index-entity (entity)
- (setf (gethash (entity-id entity) *entity-index*) entity))
-
-(defun satisfies-system-type-specifier-p (entity specifier)
- (every (lambda (component) (typep entity component))
- specifier))
-
-(defun index-entity-systems (entity)
- (iterate
- (with id = (entity-id entity))
- (for (system (function . type-specifiers)) :in-hashtable *systems*)
- (iterate
- (for argument-index :in (gethash system *system-index*))
- (for specifier :in type-specifiers)
- (when (satisfies-system-type-specifier-p entity specifier)
- (setf (gethash id argument-index) entity)))))
-
-
-(defclass entity ()
- ((id :reader entity-id :initform (incf *entity-id-counter*))))
-
-(defmethod print-object ((e entity) stream)
- (print-unreadable-object (e stream :type t :identity nil)
- (format stream "~D" (entity-id e))))
-
-(defmethod initialize-instance :after ((e entity) &key)
- (index-entity e)
- (index-entity-systems e))
-
-
-(defgeneric entity-created (entity)
- (:method ((entity entity)) nil))
-
-(defgeneric entity-destroyed (entity)
- (:method ((entity entity)) nil))
-
-
-(defun create-entity (class &rest initargs)
- (let ((entity (apply #'make-instance class initargs)))
- (entity-created entity)
- entity))
-
-(defun destroy-entity (entity)
- (let ((id (entity-id entity)))
- (remhash id *entity-index*)
- (iterate
- (for (nil index) :in-hashtable *component-index*)
- (remhash id index))
- (iterate
- (for (nil argument-indexes) :in-hashtable *system-index*)
- (iterate (for index :in argument-indexes)
- (remhash id index))))
- (entity-destroyed entity)
- nil)
-
-
-(defmacro define-entity (name components &rest slots)
- `(progn
- (defclass ,name (entity ,@components)
- (,@slots))
- (defun ,(symbolize name '?) (object)
- (typep object ',name))
- (find-class ',name)))
-
-
-(defun initialize-component-index (name)
- (gethash-or-init name *component-index* (make-hash-table)))
-
-(defmacro define-component (name &rest fields)
- (flet ((clean-field (f)
- (etypecase f
- (symbol (list f))
- (list f))))
- `(progn
- (defclass ,name ()
- ,(iterate
- (for (field . field-options) :in (mapcar #'clean-field fields))
- (for field-name = (symbolize name '/ field))
- (collect `(,field-name
- :accessor ,field-name
- :initarg ,(intern (symbol-name field-name) "KEYWORD") ; *opens trenchcoat*
- ,@field-options))))
-
- (defun ,(symbolize name '?) (object)
- (typep object ',name))
-
- (initialize-component-index ',name)
-
- (defmethod initialize-instance :after ((o ,name) &key)
- (setf (gethash (entity-id o)
- (gethash ',name *component-index*))
- o))
-
- (find-class ',name))))
-
-
-(defmacro define-system (name arglist &body body)
- `(progn
- (declaim (ftype (function
- (,@(mapcar (lambda (arg)
- `(and entity ,@(cdr arg)))
- arglist))
- (values null &optional))
- ,name))
- (defun ,name (,@(mapcar #'car arglist))
- ,@body
- nil)
- (setf (gethash ',name *systems*)
- (cons #',name ',(mapcar #'cdr arglist))
- (gethash ',name *system-index*)
- (list ,@(iterate (repeat (length arglist))
- (collect `(make-hash-table)))))
- ',name))
-
-(defun run-system (system)
- (destructuring-bind (system-function . type-specifiers)
- (gethash system *systems*)
- (declare (ignore type-specifiers))
- (apply #'map-product system-function
- (mapcar #'hash-table-values (gethash system *system-index*)))
- (values)))
-
-
-;;;; Components ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Aspects ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Coordinates
-(define-component coords
+(define-aspect coords
(x :type world-coordinate)
(y :type world-coordinate))
@@ -618,27 +454,27 @@
;;; Flavor Text
-(define-component flavor text)
+(define-aspect flavor text)
;;; Inspection
-(define-component inspectable slots)
+(define-aspect inspectable slots)
;;; Visibility
-(define-component visible glyph color)
+(define-aspect visible glyph color)
;;; Food
-(define-component edible
+(define-aspect edible
energy
original-energy)
-(define-component decomposing
+(define-aspect decomposing
rate
(remaining :initform 1.0))
-(define-component fruiting
+(define-aspect fruiting
chance)
@@ -667,7 +503,7 @@
;;;; Metabolism
-(define-component metabolizing
+(define-aspect metabolizing
insulation
energy)
@@ -695,7 +531,7 @@
;;; Brains
-(define-component sentient function)
+(define-aspect sentient function)
(define-system sentient-act ((entity sentient))
@@ -703,7 +539,7 @@
;;; Age
-(define-component aging
+(define-aspect aging
(birthtick :initform *tick*)
(age :initform 0))
@@ -1141,7 +977,7 @@
(format nil "[~D, ~D]" *view-x* *view-y*)
(format nil "[~D, ~D]" *cursor-x* *cursor-y*)
(format nil "~D creature~:P" *population*)
- (format nil "~D entit~:@P" (hash-table-count *entity-index*))
+ (format nil "~D entit~:@P" (hash-table-count beast::*entity-index*))
(format nil "~D°" *temperature*)
(format nil "tick ~D" *tick*)
(if (equal *timing* (cons 0 0))
--- a/vendor/quickutils.lisp Mon Aug 08 23:59:49 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,322 +0,0 @@
-;;;; This file was automatically generated by Quickutil.
-;;;; See http://quickutil.org for details.
-
-;;;; To regenerate:
-;;;; (qtlc:save-utils-as "vendor/quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :PARSE-BODY :DEFINE-CONSTANT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT) :ensure-package T :package "SILT.QUICKUTILS")
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package "SILT.QUICKUTILS")
- (defpackage "SILT.QUICKUTILS"
- (:documentation "Package that contains Quickutil utility functions.")
- (:use #:cl))))
-
-(in-package "SILT.QUICKUTILS")
-
-(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
- :MAKE-GENSYM-LIST :ONCE-ONLY
- :ENSURE-FUNCTION :COMPOSE :CURRY
- :RCURRY :PARSE-BODY :DEFINE-CONSTANT
- :HASH-TABLE-KEY-EXISTS-P :MAPHASH-KEYS
- :HASH-TABLE-KEYS :MAPHASH-VALUES
- :HASH-TABLE-VALUES :MAPPEND
- :MAP-PRODUCT))))
-
- (deftype string-designator ()
- "A string designator type. A string designator is either a string, a symbol,
-or a character."
- `(or symbol string character))
-
-
- (defmacro with-gensyms (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(let ,(mapcar (lambda (name)
- (multiple-value-bind (symbol string)
- (etypecase name
- (symbol
- (values name (symbol-name name)))
- ((cons symbol (cons string-designator null))
- (values (first name) (string (second name)))))
- `(,symbol (gensym ,string))))
- names)
- ,@forms))
-
- (defmacro with-unique-names (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(with-gensyms ,names ,@forms))
-
-(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
-
- (defmacro once-only (specs &body forms)
- "Evaluates `forms` with symbols specified in `specs` rebound to temporary
-variables, ensuring that each initform is evaluated only once.
-
-Each of `specs` must either be a symbol naming the variable to be rebound, or of
-the form:
-
- (symbol initform)
-
-Bare symbols in `specs` are equivalent to
-
- (symbol symbol)
-
-Example:
-
- (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
- (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
- (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
- (names-and-forms (mapcar (lambda (spec)
- (etypecase spec
- (list
- (destructuring-bind (name form) spec
- (cons name form)))
- (symbol
- (cons spec spec))))
- specs)))
- ;; bind in user-macro
- `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
- gensyms names-and-forms)
- ;; bind in final expansion
- `(let (,,@(mapcar (lambda (g n)
- ``(,,g ,,(cdr n)))
- gensyms names-and-forms))
- ;; bind in user-macro
- ,(let ,(mapcar (lambda (n g) (list (car n) g))
- names-and-forms gensyms)
- ,@forms)))))
-
-(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 compose (function &rest more-functions)
- "Returns a function composed of `function` and `more-functions` that applies its ;
-arguments to to each in turn, starting from the rightmost of `more-functions`,
-and then calling the next one with the primary value of the last."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (reduce (lambda (f g)
- (let ((f (ensure-function f))
- (g (ensure-function g)))
- (lambda (&rest arguments)
- (declare (dynamic-extent arguments))
- (funcall f (apply g arguments)))))
- more-functions
- :initial-value function))
-
- (define-compiler-macro compose (function &rest more-functions)
- (labels ((compose-1 (funs)
- (if (cdr funs)
- `(funcall ,(car funs) ,(compose-1 (cdr funs)))
- `(apply ,(car funs) arguments))))
- (let* ((args (cons function more-functions))
- (funs (make-gensym-list (length args) "COMPOSE")))
- `(let ,(loop for f in funs for arg in args
- collect `(,f (ensure-function ,arg)))
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (lambda (&rest arguments)
- (declare (dynamic-extent arguments))
- ,(compose-1 funs))))))
-
-
- (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)))))
-
-
- (defun rcurry (function &rest arguments)
- "Returns a function that applies the arguments it is called
-with and `arguments` to `function`."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (let ((fn (ensure-function function)))
- (lambda (&rest more)
- (declare (dynamic-extent more))
- (multiple-value-call fn (values-list more) (values-list arguments)))))
-
-
- (defun parse-body (body &key documentation whole)
- "Parses `body` into `(values remaining-forms declarations doc-string)`.
-Documentation strings are recognized only if `documentation` is true.
-Syntax errors in body are signalled and `whole` is used in the signal
-arguments when given."
- (let ((doc nil)
- (decls nil)
- (current nil))
- (tagbody
- :declarations
- (setf current (car body))
- (when (and documentation (stringp current) (cdr body))
- (if doc
- (error "Too many documentation strings in ~S." (or whole body))
- (setf doc (pop body)))
- (go :declarations))
- (when (and (listp current) (eql (first current) 'declare))
- (push (pop body) decls)
- (go :declarations)))
- (values body (nreverse decls) doc)))
-
-
- (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 hash-table-key-exists-p (hash-table key)
- "Does `key` exist in `hash-table`?"
- (nth-value 1 (gethash key hash-table)))
-
-
- (declaim (inline maphash-keys))
- (defun maphash-keys (function table)
- "Like `maphash`, but calls `function` with each key in the hash table `table`."
- (maphash (lambda (k v)
- (declare (ignore v))
- (funcall function k))
- table))
-
-
- (defun hash-table-keys (table)
- "Returns a list containing the keys of hash table `table`."
- (let ((keys nil))
- (maphash-keys (lambda (k)
- (push k keys))
- table)
- keys))
-
-
- (declaim (inline maphash-values))
- (defun maphash-values (function table)
- "Like `maphash`, but calls `function` with each value in the hash table `table`."
- (maphash (lambda (k v)
- (declare (ignore k))
- (funcall function v))
- table))
-
-
- (defun hash-table-values (table)
- "Returns a list containing the values of hash table `table`."
- (let ((values nil))
- (maphash-values (lambda (v)
- (push v values))
- table)
- values))
-
-
- (defun mappend (function &rest lists)
- "Applies `function` to respective element(s) of each `list`, appending all the
-all the result list to a single list. `function` must return a list."
- (loop for results in (apply #'mapcar function lists)
- append results))
-
-
- (defun map-product (function list &rest more-lists)
- "Returns a list containing the results of calling `function` with one argument
-from `list`, and one from each of `more-lists` for each combination of arguments.
-In other words, returns the product of `list` and `more-lists` using `function`.
-
-Example:
-
- (map-product 'list '(1 2) '(3 4) '(5 6))
- => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
- (2 3 5) (2 3 6) (2 4 5) (2 4 6))"
- (labels ((%map-product (f lists)
- (let ((more (cdr lists))
- (one (car lists)))
- (if (not more)
- (mapcar f one)
- (mappend (lambda (x)
- (%map-product (curry f x) more))
- one)))))
- (%map-product (ensure-function function) (cons list more-lists))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(with-gensyms with-unique-names once-only compose curry rcurry
- parse-body define-constant hash-table-key-exists-p hash-table-keys
- hash-table-values map-product)))
-
-;;;; END OF vendor/quickutils.lisp ;;;;