--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/losh.lisp Fri Aug 05 23:31:02 2016 +0000
@@ -0,0 +1,467 @@
+(in-package #:losh)
+
+
+;;;; Symbols
+(defun symbolize (&rest args)
+ "Slap `args` together stringishly into a symbol and intern it.
+
+ Example:
+
+ (symbolize 'foo :bar \"baz\")
+ => 'foobarbaz
+
+ "
+ (intern (format nil "~{~A~}" args)))
+
+
+;;;; Math
+(defparameter tau (coerce (* pi 2) 'single-float)) ; fuck a pi
+
+
+(defun square (x)
+ (* x x))
+
+(defun dividesp (n divisor)
+ "Return whether `n` is evenly divisible by `divisor`."
+ (zerop (mod n divisor)))
+
+
+(defun norm (min max val)
+ "Normalize `val` to a number between `0` and `1` (maybe).
+
+ If `val` is between `max` and `min`, the result will be a number between `0`
+ and `1`.
+
+ If `val` lies outside of the range, it'll be still be scaled and will end up
+ outside the 0/1 range.
+
+ "
+ (/ (- val min)
+ (- max min)))
+
+(defun lerp (from to n)
+ "Lerp together `from` and `to` by factor `n`.
+
+ Note that you might want `precise-lerp` instead.
+
+ "
+ (+ from
+ (* n (- to from))))
+
+(defun precise-lerp (from to n)
+ "Lerp together `from` and `to` by factor `n`, precisely.
+
+ Vanilla lerp does not guarantee `(lerp from to 0.0)` will return exactly
+ `from` due to floating-point errors. This version will return exactly `from`
+ when given a `n` of `0.0`, at the cost of an extra multiplication.
+
+ "
+ (+ (* (- 1 n) from)
+ (* n to)))
+
+(defun map-range (source-from source-to dest-from dest-to source-val)
+ "Map `source-val` from the source range to the destination range.
+
+ Example:
+
+ ; source dest value
+ (map-range 0.0 1.0 10.0 20.0 0.2)
+ => 12.0
+
+ "
+ (lerp dest-from dest-to
+ (norm source-from source-to source-val)))
+
+(defun clamp (from to value)
+ "Clamp `value` between `from` and `to`."
+ (let ((max (max from to))
+ (min (min from to)))
+ (cond
+ ((> value max) max)
+ ((< value min) min)
+ (t value))))
+
+
+;;;; Random
+(defun randomp ()
+ "Return a random boolean."
+ (zerop (random 2)))
+
+(defun random-elt (seq)
+ "Return a random element of `seq`, and whether one was available.
+
+ This will NOT be efficient for lists.
+
+ Examples:
+
+ (random-elt #(1 2 3))
+ => 1
+ T
+
+ (random-elt nil)
+ => nil
+ nil
+
+ "
+ (let ((length (length seq)))
+ (if (zerop length)
+ (values nil nil)
+ (values (elt seq (random length)) t))))
+
+(defun random-range (min max)
+ "Return a random number between [`min`, `max`)."
+ (+ min (random (- max min))))
+
+(defun random-range-exclusive (min max)
+ "Return a random number between (`min`, `max`)."
+ (+ 1 min (random (- max min 1))))
+
+(defun random-around (value spread)
+ "Return a random number within `spread` of `value`."
+ (random-range (- value spread)
+ (+ value spread)))
+
+(defun d (n sides &optional (plus 0))
+ "Roll some dice.
+
+ Examples:
+
+ (d 1 4) ; rolls 1d4
+ (d 2 8) ; rolls 2d8
+ (d 1 10 -1) ; rolls 1d10-1
+
+ "
+ (+ (iterate (repeat n)
+ (sum (1+ (random sides))))
+ plus))
+
+
+;;;; Functions
+(defun juxt (&rest fns)
+ "Return a function that will juxtipose the results of `functions`.
+
+ This is like Clojure's `juxt`. Given functions `(f0 f1 ... fn)`, this will
+ return a new function which, when called with some arguments, will return
+ `(list (f0 ...args...) (f1 ...args...) ... (fn ...args...))`.
+
+ Example:
+
+ (funcall (juxt #'list #'+ #'- #'*) 1 2)
+ => ((1 2) 3 -1 2)
+
+ "
+ (lambda (&rest args)
+ (mapcar (rcurry #'apply args) fns)))
+
+
+;;;; Control Flow
+(defmacro recursively (bindings &body body)
+ "Execute body recursively, like Clojure's `loop`/`recur`.
+
+ `bindings` should contain a list of symbols and (optional) default values.
+
+ In `body`, `recur` will be bound to the function for recurring.
+
+ Example:
+
+ (defun length (some-list)
+ (recursively ((list some-list) (n 0))
+ (if (null list)
+ n
+ (recur (cdr list) (1+ n)))))
+
+ "
+ (flet ((extract-var (binding)
+ (if (atom binding) binding (first binding)))
+ (extract-val (binding)
+ (if (atom binding) nil (second binding))))
+ `(labels ((recur ,(mapcar #'extract-var bindings)
+ ,@body))
+ (recur ,@(mapcar #'extract-val bindings)))))
+
+
+;;;; Mutation
+(defmacro zap% (place function &rest arguments &environment env)
+ "Update `place` by applying `function` to its current value and `arguments`.
+
+ `arguments` should contain the symbol `%`, which is treated as a placeholder
+ where the current value of the place will be substituted into the function
+ call.
+
+ For example:
+
+ (zap% foo #'- % 10) => (setf foo (- foo 10)
+ (zap% foo #'- 10 %) => (setf foo (- 10 foo)
+
+ "
+ ;; original idea/name from http://malisper.me/2015/09/29/zap/
+ (assert (find '% arguments)
+ ()
+ "Placeholder % not included in zap macro form.")
+ (multiple-value-bind (temps exprs stores store-expr access-expr)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list temps exprs)
+ (,(car stores)
+ (funcall ,function
+ ,@(substitute access-expr '% arguments))))
+ ,store-expr)))
+
+(defmacro mulf (place n)
+ "Multiply `place` by `n` in-place."
+ `(zap% ,place #'* % ,n))
+
+(defmacro zapf (place function)
+ "Update `place` with the result of calling `function` on it."
+ `(zap% ,place ,function %))
+
+
+;;;; Hash Tables
+(defmacro gethash-or-init (key hash-table default-form)
+ "Get `key`'s value in `hash-table`, initializing if necessary.
+
+ If `key` is in `hash-table`: return its value without evaluating
+ `default-form` at all.
+
+ If `key` is NOT in `hash-table`: evaluate `default-form` and insert it before
+ returning it.
+
+ "
+ ;; TODO: think up a less shitty name for this
+ (once-only (key hash-table)
+ (with-gensyms (value found)
+ `(multiple-value-bind (,value ,found)
+ (gethash ,key ,hash-table)
+ (if ,found
+ ,value
+ (setf (gethash ,key ,hash-table) ,default-form))))))
+
+
+;;;; Queues
+;;; Based on the PAIP queues (thanks, Norvig), but beefed up a little bit to add
+;;; tracking of the queue size.
+
+(declaim (inline make-queue enqueue dequeue queue-empty-p))
+
+(defstruct (queue (:constructor make-queue%))
+ (contents nil :type list)
+ (last nil :type list)
+ (size 0 :type fixnum))
+
+
+(defun make-queue ()
+ (make-queue%))
+
+(defun queue-empty-p (q)
+ (zerop (queue-size q)))
+
+(defun enqueue (item q)
+ (let ((cell (cons item nil)))
+ (setf (queue-last q)
+ (if (queue-empty-p q)
+ (setf (queue-contents q) cell)
+ (setf (cdr (queue-last q)) cell))))
+ (incf (queue-size q)))
+
+(defun dequeue (q)
+ (when (zerop (decf (queue-size q)))
+ (setf (queue-last q) nil))
+ (pop (queue-contents q)))
+
+(defun queue-append (q l)
+ (loop :for item :in l
+ :for size = (enqueue item q)
+ :finally (return size)))
+
+
+;;;; Iterate
+(defmacro-driver (FOR var PAIRS-OF-LIST list)
+ "Iterate over the all pairs of the (including (last . first))."
+ (let ((kwd (if generate 'generate 'for)))
+ (with-gensyms (current l)
+ `(progn
+ (with ,l = ,list)
+ (with ,current = ,l)
+ (,kwd ,var next
+ (cond
+ ((null ,current)
+ (terminate))
+
+ ((null (cdr ,current))
+ (prog1
+ (cons (first ,current) (car ,l))
+ (setf ,current nil)))
+
+ (t
+ (prog1
+ (cons (first ,current) (second ,current))
+ (setf ,current (cdr ,current))))))))))
+
+
+(defmacro-clause (AVERAGING expr &optional INTO var)
+ (with-gensyms (count)
+ (let ((average (or var (gensym "average"))))
+ `(progn
+ (for ,average
+ :first ,expr
+ ;; continuously recompute the running average instead of keeping
+ ;; a running total to avoid bignums when possible
+ :then (/ (+ (* ,average ,count)
+ ,expr)
+ (1+ ,count)))
+ (for ,count :from 1)
+ ,(when (null var)
+ ;; todo handle this better
+ `(finally (return ,average)))))))
+
+(defmacro-clause (TIMING time-type &optional SINCE-START-INTO var PER-ITERATION-INTO per)
+ (let ((timing-function (ecase time-type
+ ((real-time) #'get-internal-real-time)
+ ((run-time) #'get-internal-run-time)))
+ (since (or var (gensym))))
+ (with-gensyms (start-time current-time previous-time)
+ `(progn
+ (with ,start-time = (funcall ,timing-function))
+ (for ,current-time = (funcall ,timing-function))
+ (for ,previous-time :previous ,current-time :initially ,start-time)
+ (for ,since = (- ,current-time ,start-time))
+ ,(when per
+ `(for ,per = (- ,current-time ,previous-time)))
+ ,(when (and (null var) (null per))
+ `(finally (return ,since)))))))
+
+
+(defmacro-driver (FOR var IN-LISTS lists)
+ (let ((kwd (if generate 'generate 'for)))
+ (with-gensyms (list)
+ `(progn
+ (generate ,list :in (remove nil (list ,@lists)))
+ (,kwd ,var next (progn (when (null ,list)
+ (next ,list))
+ (pop ,list)))))))
+
+
+(defun seq-done-p (seq len idx)
+ (if idx
+ (= idx len)
+ (null seq)))
+
+(defmacro-driver (FOR var IN-SEQUENCES seqs)
+ (let ((kwd (if generate 'generate 'for)))
+ (with-gensyms (seq len idx)
+ `(progn
+ (with ,len = nil)
+ (with ,idx = nil)
+ (generate ,seq :in (remove-if #'emptyp (list ,@seqs)))
+ (,kwd ,var next
+ (progn
+ (when (seq-done-p ,seq ,len ,idx)
+ (etypecase (next ,seq)
+ (cons (setf ,len nil ,idx nil))
+ (sequence (setf ,len (length ,seq)
+ ,idx 0))))
+ (if ,idx
+ (prog1 (elt ,seq ,idx)
+ (incf ,idx))
+ (pop ,seq))))))))
+
+
+;;;; Hash Sets
+(defclass hash-set ()
+ ((data :initarg :data)))
+
+
+(defun make-set (&key (test #'eql) (initial-data nil))
+ (let ((set (make-instance 'hash-set
+ :data (make-hash-table :test test))))
+ (mapcar (curry #'set-add set) initial-data)
+ set))
+
+
+(defun set-contains-p (set value)
+ (nth-value 1 (gethash value (slot-value set 'data))))
+
+(defun set-empty-p (set)
+ (zerop (hash-table-count (slot-value set 'data))))
+
+(defun set-add (set value)
+ (setf (gethash value (slot-value set 'data)) t)
+ value)
+
+(defun set-add-all (set seq)
+ (map nil (curry #'set-add set) seq))
+
+(defun set-remove (set value)
+ (remhash value (slot-value set 'data))
+ value)
+
+(defun set-remove-all (set seq)
+ (map nil (curry #'set-remove set) seq))
+
+(defun set-clear (set)
+ (clrhash (slot-value set 'data))
+ set)
+
+(defun set-random (set)
+ (if (set-empty-p set)
+ (values nil nil)
+ (loop :with data = (slot-value set 'data)
+ :with target = (random (hash-table-count data))
+ :for i :from 0
+ :for k :being :the :hash-keys :of data
+ :when (= i target)
+ :do (return (values k t)))))
+
+(defun set-pop (set)
+ (multiple-value-bind (val found) (set-random set)
+ (if found
+ (progn
+ (set-remove set val)
+ (values val t))
+ (values nil nil))))
+
+
+(defmethod print-object ((set hash-set) stream)
+ (print-unreadable-object (set stream :type t)
+ (format stream "~{~S~^ ~}"
+ (iterate (for (key nil) :in-hashtable (slot-value set 'data))
+ (collect key)))))
+
+
+;;;; Debugging & Logging
+(defun pr (&rest args)
+ (format t "~{~S~^ ~}~%" args)
+ (finish-output)
+ (values))
+
+(defun bits (n size)
+ ;; http://blog.chaitanyagupta.com/2013/10/print-bit-representation-of-signed.html
+ (format t (format nil "~~~D,'0B" size) (ldb (byte size 0) n))
+ (values))
+
+
+;;;; File IO
+(defun slurp (path)
+ "Sucks up an entire file from PATH into a freshly-allocated string,
+ returning two values: the string and the number of bytes read."
+ (with-open-file (s path)
+ (let* ((len (file-length s))
+ (data (make-string len)))
+ (values data (read-sequence data s)))))
+
+(defun spit (path str)
+ "Spit the string into a file at the given path."
+ (with-open-file (s path :direction :output :if-exists :supersede)
+ (format s "~A" str)))
+
+
+;;;; dlambda
+;;; From Let Over Lambda.
+(defmacro dlambda (&rest clauses)
+ (with-gensyms (message arguments)
+ (flet ((parse-clause (clause)
+ (destructuring-bind (key arglist &rest body)
+ clause
+ `(,key (apply (lambda ,arglist ,@body) ,arguments)))))
+ `(lambda (,message &rest ,arguments)
+ (ecase ,message
+ ,@(mapcar #'parse-clause clauses))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/quickutils.lisp Fri Aug 05 23:31:02 2016 +0000
@@ -0,0 +1,158 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :RCURRY :WITH-GENSYMS :ONCE-ONLY) :ensure-package T :package "LOSH.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "LOSH.QUICKUTILS")
+ (defpackage "LOSH.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "LOSH.QUICKUTILS")
+
+(when (boundp '*utilities*)
+ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
+ :CURRY :RCURRY :STRING-DESIGNATOR
+ :WITH-GENSYMS :ONCE-ONLY))))
+(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
+(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 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)))))
+
+
+ (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))
+
+
+ (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)
+ (export '(curry rcurry with-gensyms with-unique-names once-only)))
+
+;;;; END OF quickutils.lisp ;;;;