# HG changeset patch # User Steve Losh # Date 1502304932 14400 # Node ID 7528d18f2430b7513c426bd90d0a0e3b607a5b73 # Parent 61ec616b45f8d1a9c497bcaf4e9202769127252b Add `hex` and some other minor features/fixes diff -r 61ec616b45f8 -r 7528d18f2430 DOCUMENTATION.markdown --- a/DOCUMENTATION.markdown Fri Aug 04 23:13:23 2017 -0400 +++ b/DOCUMENTATION.markdown Wed Aug 09 14:55:32 2017 -0400 @@ -547,7 +547,7 @@ ### `BITS` (function) - (BITS N SIZE &OPTIONAL (STREAM T)) + (BITS &OPTIONAL (N *) (SIZE 8) (STREAM T)) Print the bits of the `size`-bit two's complement integer `n` to `stream`. @@ -592,6 +592,22 @@ &BODY BODY) +### `HEX` (function) + + (HEX &OPTIONAL (THING *) (STREAM T)) + +Print the `thing` to `stream` with numbers in base 16. + + Examples: + + (hex 255) + => FF + + (hex #(0 128)) + => #(0 80) + + + ### `PHT` (function) (PHT HASH-TABLE &OPTIONAL (STREAM T)) @@ -909,7 +925,14 @@ ### `COPY-HASH-SET` (function) - (COPY-HASH-SET INSTANCE) + (COPY-HASH-SET HSET) + +Create a (shallow) copy of the given hash set. + + Only the storage for the hash set itself will be copied -- the elements + themselves will not be copied. + + ### `HASH-SET` (struct) diff -r 61ec616b45f8 -r 7528d18f2430 losh.lisp --- a/losh.lisp Fri Aug 04 23:13:23 2017 -0400 +++ b/losh.lisp Wed Aug 09 14:55:32 2017 -0400 @@ -1440,7 +1440,8 @@ (defmacro-clause (FOR delta-vars WITHIN-RADIUS radius &optional - SKIP-ORIGIN should-skip-origin) + SKIP-ORIGIN should-skip-origin + ORIGIN origin) "Iterate through a number of delta values within a given radius. Imagine you have a 2D array and you want to find all the neighbors of a given @@ -1486,19 +1487,29 @@ ; the point it is works in arbitrary dimensions. " - (with-gensyms (r -r control skip) - `(progn - (with ,r = ,radius) - (with ,-r = (- ,r)) - (with ,skip = ,should-skip-origin) - (generate-nested ,(iterate (for var :in (ensure-list delta-vars)) - (collect `(,var :from ,-r :to ,r))) - :control-var ,control) - (next ,control) - (when (and ,skip - ,@(iterate (for var :in (ensure-list delta-vars)) - (collect `(zerop ,var)))) - (next ,control))))) + (let* ((delta-vars (ensure-list delta-vars)) + (origin-vars (mapcar (lambda (dv) (gensym (mkstr 'origin- dv))) + delta-vars)) + (origin-vals (if (null origin) + (mapcar (constantly 0) delta-vars) + origin))) + (with-gensyms (r -r control skip) + `(progn + (with ,r = ,radius) + ,@(mapcar (lambda (ovar oval) + `(with ,ovar = ,oval)) + origin-vars origin-vals) + (generate-nested ,(iterate (for var :in delta-vars) + (for orig :in origin-vars) + (collect `(,var :from (- ,orig ,r) :to (+ ,orig ,r)))) + :control-var ,control) + (next ,control) + ,@(unless (null should-skip-origin) + `((with ,skip = ,should-skip-origin) + (when (and ,skip + ,@(iterate (for var :in (ensure-list delta-vars)) + (collect `(zerop ,var)))) + (next ,control)))))))) (defmacro-driver (FOR var EVERY-NTH n DO form) @@ -1580,11 +1591,11 @@ (defmacro-clause (ORING expr &optional INTO var) (let ((result (or var iterate::*result-var*))) - `(reducing ,expr :by #'or :into ,var :initial-value nil))) + `(reducing ,expr :by #'or :into ,result :initial-value nil))) (defmacro-clause (ANDING expr &optional INTO var) (let ((result (or var iterate::*result-var*))) - `(reducing ,expr :by #'and :into ,var :initial-value t))) + `(reducing ,expr :by #'and :into ,result :initial-value t))) (defun keywordize-clause (clause) @@ -1962,7 +1973,7 @@ (finish-output))) -(defun bits (n size &optional (stream t)) +(defun bits (&optional (n *) (size 8) (stream t)) "Print the bits of the `size`-bit two's complement integer `n` to `stream`. Examples: @@ -1975,8 +1986,25 @@ " ;; http://blog.chaitanyagupta.com/2013/10/print-bit-representation-of-signed.html - (format stream (format nil "~~~D,'0B" size) (ldb (byte size 0) n)) - (values)) + (format stream (format nil "~~~D,'0B" size) (ldb (byte size 0) n))) + +(defun hex (&optional (thing *) (stream t)) + "Print the `thing` to `stream` with numbers in base 16. + + Examples: + + (hex 255) + => FF + + (hex #(0 128)) + => #(0 80) + + " + (let ((*print-base* 16)) + (case stream + ((nil) (prin1-to-string thing)) + ((t) (prin1 thing stream) (terpri stream) nil) + (otherwise (prin1 thing stream) (terpri stream) nil)))) (defmacro shut-up (&body body) "Run `body` with stdout and stderr redirected to the void." @@ -2298,7 +2326,8 @@ ;;;; Hash Sets ---------------------------------------------------------------- -(defstruct (hash-set (:constructor make-hash-set%)) +(defstruct (hash-set (:constructor make-hash-set%) + (:copier nil)) (storage (error "Required") :type hash-table :read-only t)) (defmethod print-object ((hset hash-set) stream) diff -r 61ec616b45f8 -r 7528d18f2430 package.lisp --- a/package.lisp Fri Aug 04 23:13:23 2017 -0400 +++ b/package.lisp Wed Aug 09 14:55:32 2017 -0400 @@ -77,22 +77,26 @@ (defpackage :losh.debugging (:documentation "Utilities for figuring out what the hell is going on.") (:export - :pr - :prl - :bits - :shut-up - :dis - :comment - :aesthetic-string - :structural-string - :gimme + + #+sbcl :profile #+sbcl :start-profiling #+sbcl :stop-profiling - #+sbcl :profile - :print-table + :aesthetic-string + :bits + :comment + :dis + :gimme + :hex + :pht + :pr :print-hash-table :print-hash-table-concisely - :pht)) + :print-table + :prl + :shut-up + :structural-string + + )) (defpackage :losh.eldritch-horrors (:documentation "Abandon all hope, ye who enter here.") diff -r 61ec616b45f8 -r 7528d18f2430 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Fri Aug 04 23:13:23 2017 -0400 +++ b/vendor/make-quickutils.lisp Wed Aug 09 14:55:32 2017 -0400 @@ -11,6 +11,7 @@ :ensure-keyword :ensure-list :flatten + :hash-table-alist :hash-table-keys :hash-table-values :map-tree diff -r 61ec616b45f8 -r 7528d18f2430 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Fri Aug 04 23:13:23 2017 -0400 +++ b/vendor/quickutils.lisp Wed Aug 09 14:55:32 2017 -0400 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :EMPTYP :ENSURE-KEYWORD :ENSURE-LIST :FLATTEN :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-TREE :MKSTR :ONCE-ONLY :RANGE :RCURRY :SYMB :WEAVE :WITH-GENSYMS) :ensure-package T :package "LOSH.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :EMPTYP :ENSURE-KEYWORD :ENSURE-LIST :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-TREE :MKSTR :ONCE-ONLY :RANGE :RCURRY :SYMB :WEAVE :WITH-GENSYMS) :ensure-package T :package "LOSH.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "LOSH.QUICKUTILS") @@ -16,7 +16,8 @@ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION :COMPOSE :COPY-HASH-TABLE :CURRY :NON-ZERO-P :EMPTYP :ENSURE-KEYWORD - :ENSURE-LIST :FLATTEN :MAPHASH-KEYS + :ENSURE-LIST :FLATTEN + :HASH-TABLE-ALIST :MAPHASH-KEYS :HASH-TABLE-KEYS :MAPHASH-VALUES :HASH-TABLE-VALUES :MAP-TREE :MKSTR :ONCE-ONLY :RANGE :RCURRY :SYMB :WEAVE @@ -152,6 +153,16 @@ (rec xs nil))) + (defun hash-table-alist (table) + "Returns an association list containing the keys and values of hash table +`table`." + (let ((alist nil)) + (maphash (lambda (k v) + (push (cons k v) alist)) + table) + alist)) + + (declaim (inline maphash-keys)) (defun maphash-keys (function table) "Like `maphash`, but calls `function` with each key in the hash table `table`." @@ -326,7 +337,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (export '(compose copy-hash-table curry emptyp ensure-keyword ensure-list - flatten hash-table-keys hash-table-values map-tree mkstr once-only - range rcurry symb weave with-gensyms with-unique-names))) + flatten hash-table-alist hash-table-keys hash-table-values map-tree + mkstr once-only range rcurry symb weave with-gensyms + with-unique-names))) ;;;; END OF quickutils.lisp ;;;;