From e7f2bf5bc1cfdcc917ab416fe8f99244ca03b05a Mon Sep 17 00:00:00 2001 From: Kyle Date: Sat, 29 Aug 2015 18:22:13 -0700 Subject: [PATCH] Adding more utilities and organising code. --- kutils-hash-tables.lisp | 108 ++++++++++++++++++++++++++++++++++++++ kutils.asd | 3 +- kutils.lisp | 111 ++++++++-------------------------------- package.lisp | 19 +++++-- 4 files changed, 148 insertions(+), 93 deletions(-) create mode 100644 kutils-hash-tables.lisp diff --git a/kutils-hash-tables.lisp b/kutils-hash-tables.lisp new file mode 100644 index 0000000..56b252a --- /dev/null +++ b/kutils-hash-tables.lisp @@ -0,0 +1,108 @@ +(in-package #:kutils) + +;;; hash-table functions. + + +(defun |#{-reader| (stream sub-char numarg) + (declare (ignore sub-char numarg)) + (let ((m (make-hash-table :test 'equal)) + (k nil) + (v nil) + (key-p t)) + (labels ((finalise-read (x) + (reverse (concatenate 'string x))) + (finalise-kv-pair () + (if key-p + (unless (null k) + (setq key-p nil + k (read-from-string (finalise-read k)))) + (unless (null v) + (setq key-p t + v (read-from-string (finalise-read v))) + (setf (gethash k m) v) + (setq k nil v nil)))) + (reading-complete-p () + (and (null v) + (not + (null k))))) + (do ((prev (read-char stream) curr) + (curr (read-char stream) (read-char stream))) + ((and (char= prev #\}) (char= curr #\#))) + (if (char= prev #\Space) + (finalise-kv-pair) + (if key-p + (push prev k) + (push prev v)))) + (if (reading-complete-p) + (error "Mismatched key value pairs.") + (progn + (finalise-kv-pair) + m))))) + +(defun enable-hash-table-reader () + "Enables the reader macro #{}# for hash-tables. The resulting +hash-table will use #'equal for equality. For example, + +#{:a :b :c :d}# + +will create a hash-table with the keys :a and :c. :a stores the +value :b, and :c stores the value :d. +" + (set-dispatch-macro-character + #\# #\{ #'|#{-reader|)) + +(defun sethash (k v m) + "Convenience notation for setting a value in a hash table." + (setf (gethash k m) v)) + +(defun hashkeys (m) + "Returns a list of the keys in the hash table." + (let ((keys '())) + (maphash (lambda (k v) + (declare (ignore v)) + (push k keys)) + m) + keys)) + +(defun hash-table-to-alist (m) + "Converts the hash-table given to an alist of (key . value) pairs." + (let ((alist '())) + (maphash (lambda (k v) + (let ((elt (cons k v))) + (setf alist (cons elt alist)))) + m) + alist)) + +(defun alist-to-hash-table (alist) + "Converts the alist to a hash-table." + (let ((m (make-hash-table :test 'equal))) + (dolist (elt alist) + (sethash (car elt) (cdr elt) m)) + m)) + + +(defun copy-hash-table (ht) + (let ((copied (make-hash-table :equal #'equal))) + (maphash (lambda (k v) + (sethash k v copied)) + ht) + copied)) + +(defun new-hash-table () + "Create a new hash table with the #'equal function as its test." + (make-hash-table :test #'equal)) + +(defmacro with-new-hash-table (htsyms &body body) + "with-new-hash-table creates and binds a new hash table for each of +the symbols in htsyms, executing inside a let form, and returns the +hash table(s). If only one hash table is provided, return it as a +single element; otherwise, return an alist of the symbol names and +hash tables." + `(let ,(mapcar (lambda (sym) + (list sym (list 'new-hash-table))) htsyms) + ,@body + ,(if (null (rest htsyms)) + (first htsyms) + `(mapcar #'cons + (mapcar #'mksymb (quote ,htsyms)) + (list ,@htsyms))))) diff --git a/kutils.asd b/kutils.asd index a32bc63..7a0c1e8 100644 --- a/kutils.asd +++ b/kutils.asd @@ -9,5 +9,6 @@ :components ((:file "package") (:file "on") (:file "lol") - (:file "kutils"))) + (:file "kutils") + (:file "kutils-hash-tables"))) diff --git a/kutils.lisp b/kutils.lisp index 18e59b3..96d4572 100644 --- a/kutils.lisp +++ b/kutils.lisp @@ -127,95 +127,28 @@ produces '((a 1) (b 2) (c 3))." (zip-acc lsts))) -;;; hash-table functions. +(defun read-file-string (path) + "Read the contents of the file at path as a string." + (with-open-file (s path) + (let ((data (make-string (file-length s)))) + (read-sequence data s) + data))) +(defun new-vector () + "Create a new, empty, adjustable vector with fill pointer." + (make-array 0 :adjustable t :fill-pointer t)) -(defun |#{-reader| (stream sub-char numarg) - (declare (ignore sub-char numarg)) - (let ((m (make-hash-table :test 'equal)) - (k nil) - (v nil) - (key-p t)) - (labels ((finalise-read (x) - (reverse (concatenate 'string x))) - (finalise-kv-pair () - (if key-p - (unless (null k) - (setq key-p nil - k (read-from-string (finalise-read k)))) - (unless (null v) - (setq key-p t - v (read-from-string (finalise-read v))) - (setf (gethash k m) v) - (setq k nil v nil)))) - (reading-complete-p () - (and (null v) - (not - (null k))))) - (do ((prev (read-char stream) curr) - (curr (read-char stream) (read-char stream))) - ((and (char= prev #\}) (char= curr #\#))) - (if (char= prev #\Space) - (finalise-kv-pair) - (if key-p - (push prev k) - (push prev v)))) - (if (reading-complete-p) - (error "Mismatched key value pairs.") - (progn - (finalise-kv-pair) - m))))) +(defmacro mapv (fn &rest vecs) + "Utility to map @c(fn) over the vectors @c(vecs), producing a vector." + `(map 'vector ,fn ,@vecs)) + +(defun vectorise (lst) + "Ensure @c(lst) is a vector." + (cond ((listp lst) (apply #'vector lst)) + ((vectorp lst) lst) + (otherwise (mapv #'identity lst)))) -(defun enable-hash-table-reader () - "Enables the reader macro #{}# for hash-tables. The resulting -hash-table will use #'equal for equality. For example, - -#{:a :b :c :d}# - -will create a hash-table with the keys :a and :c. :a stores the -value :b, and :c stores the value :d. -" - (set-dispatch-macro-character - #\# #\{ #'|#{-reader|)) - -(defun sethash (k v m) - "Convenience notation for setting a value in a hash table." - (setf (gethash k m) v)) - -(defun hashkeys (m) - "Returns a list of the keys in the hash table." - (let ((keys '())) - (maphash (lambda (k v) - (declare (ignore v)) - (push k keys)) - m) - keys)) - -(defun hash-table-to-alist (m) - "Converts the hash-table given to an alist of (key . value) pairs." - (let ((alist '())) - (maphash (lambda (k v) - (let ((elt (cons k v))) - (setf alist (cons elt alist)))) - m) - alist)) - -(defun alist-to-hash-table (alist) - "Converts the alist to a hash-table." - (let ((m (make-hash-table :test 'equal))) - (dolist (elt alist) - (sethash (car elt) (cdr elt) m)) - m)) - - -(defun copy-hash-table (ht) - (let ((copied (make-hash-table :equal #'equal))) - (maphash (lambda (k v) - (sethash k v copied)) - ht) - copied)) - - ;; (defun ,ctor (&key ,@(append (inherited-slots supers) - ;; slots)) - ;; (make-instance (find-class ,name t nil) - ;; ,@(flatten (build-arg-list all-slots)))) +(defmacro assoc-val (item alist &rest key-args) + "Return the value of @c(item) in @c(alist). @c(key-args) should +contain any additional keyword arguments to @c(assoc)." + `(first (assoc ,item ,alist ,@key-args))) diff --git a/package.lisp b/package.lisp index 7672002..de8cf36 100644 --- a/package.lisp +++ b/package.lisp @@ -2,13 +2,18 @@ (defpackage #:kutils (:use #:cl) - (:export #:mkstr ; On Lisp utilities + (:export ;; on.lisp : utilities from Graham's On Lisp. + #:mkstr #:symb #:group #:flatten #:compose - #:defmacro! ; Let Over Lambda utilities - #:interpose ; My utilities + + ;; lol.lisp : utilities from Let Over Lambda + #:defmacro! + + ;; kutils.lisp + #:interpose #:take #:drop #:build-list @@ -18,9 +23,17 @@ #:mkkw #:defclass! #:zip + #:new-vector + #:mapv + #:vectorise + #:assoc-val + + ;; kutils-hash-tables.lisp #:enable-hash-table-reader #:hashkeys #:sethash #:hash-table-to-alist #:alist-to-hash-table + #:new-hash-table + #:with-new-hash-table ))