# HG changeset patch # User Steve Losh # Date 1470766158 0 # Node ID a5438ac6a2a023d5e94d3e440d0647af8f63b8ef # Parent a20cf05534d1c9c0233bfc17f25169b14563cfd5 Split out the EAS diff -r a20cf05534d1 -r a5438ac6a2a0 Makefile --- 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 diff -r a20cf05534d1 -r a5438ac6a2a0 make-quickutils.lisp --- 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 diff -r a20cf05534d1 -r a5438ac6a2a0 package.lisp --- 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)) diff -r a20cf05534d1 -r a5438ac6a2a0 quickutils.lisp --- /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 ;;;; diff -r a20cf05534d1 -r a5438ac6a2a0 silt.asd --- 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"))) diff -r a20cf05534d1 -r a5438ac6a2a0 silt.lisp --- 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)) diff -r a20cf05534d1 -r a5438ac6a2a0 vendor/quickutils.lisp --- 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 ;;;;