commit ac9064bb54bc8edc8c5153dd075693871e550987 Author: Kyle Date: Sun Apr 5 22:24:50 2015 -0700 Initial import. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..72b0d98 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*~ +*.fasl \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e81ea15 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2015 Kyle Isom + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. \ No newline at end of file diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..975733f --- /dev/null +++ b/README.txt @@ -0,0 +1 @@ +This is the stub README.txt for the "kutils" project. diff --git a/kutils.asd b/kutils.asd new file mode 100644 index 0000000..37e9dd4 --- /dev/null +++ b/kutils.asd @@ -0,0 +1,12 @@ +;;;; kutils.asd + +(asdf:defsystem #:kutils + :description "Kyle's utility package" + :author "K. Isom " + :license "MIT License" + :serial t + :components ((:file "package") + (:file "on") + (:file "lol") + (:file "kutils"))) + diff --git a/kutils.lisp b/kutils.lisp new file mode 100644 index 0000000..3f8e612 --- /dev/null +++ b/kutils.lisp @@ -0,0 +1,70 @@ +;;;; kutils.lisp + +(in-package #:kutils) + +;;; "kutil" goes here. Hacks and glory await! + +(defun join (x sep) + (flatten + (mapcar (lambda (y) + (list y sep)) + x))) + + +;;; 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 + (progn + (setq key-p nil + k (read-from-string (finalise-read k)))) + (progn + (setq key-p t + v (read-from-string (finalise-read v))) + (setf (gethash k m) v) + (setq k nil v nil))))) + (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 key-p + (error "Mismatched key value pairs.") + (progn + (finalise-kv-pair) + m))))) + +(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 hashtable-to-alist (m) + (let ((alist '())) + (maphash (lambda (k v) + (let ((elt (cons k v))) + (setf alist (cons elt alist)))) + m) + alist)) diff --git a/lol.lisp b/lol.lisp new file mode 100644 index 0000000..a1d7434 --- /dev/null +++ b/lol.lisp @@ -0,0 +1,51 @@ +(in-package #:kutils) + +;;;; Utilities from Let Over Lambda. This source code is provided +;;;; under the following license: + + +(defun g!-symbol-p (s) + (and (symbolp s) + (> (length (symbol-name s)) 2) + (string= (symbol-name s) + "G!" + :start1 0 + :end1 2))) + +(defmacro defmacro/g! (name args &rest body) + "defmacro/g! provides automatic gensyms for all arguments starting +with g!." + (let ((syms (remove-duplicates + (remove-if-not #'g!-symbol-p + (flatten body))))) + `(defmacro ,name ,args + (let ,(mapcar + (lambda (s) + `(,s (gensym ,(subseq + (symbol-name s) + 2)))) + syms) + ,@body)))) + +(defun o!-symbol-p (s) + (and (symbolp s) + (> (length (symbol-name s)) 2) + (string= (symbol-name s) + "O!" + :start1 0 + :end1 2))) + +(defun o!-symbol-to-g!-symbol (s) + (symb "G!" (subseq (symbol-name s) 2))) + +(defmacro defmacro! (name args &rest body) + "defmacro! provides automatic gensyms and once-only +evaluation. Arguments that begin with g! will be automatically +gensym'd, and arguments that begin with o! will only be evaluated +once. Inside the body, the o! arguments should be called as their +equivalent g! argument: o!x should be called in the body as g!x." + (let* ((os (remove-if-not #'o!-symbol-p args)) + (gs (mapcar #'o!-symbol-to-g!-symbol os))) + `(defmacro/g! ,name ,args + `(let ,(mapcar #'list (list ,@gs) (list ,@os)) + ,(progn ,@body))))) diff --git a/on.lisp b/on.lisp new file mode 100644 index 0000000..b8fd97d --- /dev/null +++ b/on.lisp @@ -0,0 +1,55 @@ +(in-package #:kutils) + +;;;; The utilities in this file come from the book On Lisp by Paul +;;;; Graham. + +(defun mkstr (&rest args) + "Concatenates its symbols and returns the printable representation +of the result." + (with-output-to-string (s) + (dolist (a args) (princ a s)))) + +(defun symb (&rest args) + "Passes its arguments to mkstr to produce a printable +representation, and returns the symbol built from this result; if the +symbol does not exist, it will be created." + (values (intern (apply #'mkstr args)))) + +(defun group (source n) + "Group takes a list as input and produces a list of sublists of +length n." + (when (zerop n) (error "zero length")) + (labels ((rec (source acc) + (let ((rest (nthcdr n source))) + (if (consp rest) + (rec rest (cons + (subseq source 0 n) + acc)) + (nreverse (cons source acc)))))) + (if source (rec source nil) nil))) + +(defun flatten (x) + "Returns a list of all atoms present in the provided list. Of +historical note, this was originally provided in Interlisp." + (labels ((rec (x acc) + (cond ((null x) acc) + ((atom x) (cons x acc)) + (t (rec (car x) + (rec (cdr x) acc)))))) + (rec x nil))) + +;;; compose may have been one of the first functions that really made +;;; me pay attention to Lisp. I'm not sure why, particularly, but it +;;; helped spur further Lisp explorations.n + +(defun compose (&rest fns) + "Compose allows a number of functions with the same arity to be +composed together in a chain." + (if fns + (let ((fn1 (car (last fns))) + (fns (butlast fns))) + #'(lambda (&rest args) + (reduce #'funcall fns + :from-end t + :initial-value (apply fn1 args)))) + #'identity)) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..8ff12f3 --- /dev/null +++ b/package.lisp @@ -0,0 +1,14 @@ +;;;; package.lisp + +(defpackage #:kutils + (:use #:cl) + (:export #:mkstr ; On Lisp utilities + #:symbb + #:group + #:flatten + #:compose + #:defmacro! ; Let Over Lambda utilities + #:join ; My utilities + #:sethash + )) +