# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1467829778 0
# Node ID 50ab2f9c5b2fa2145c31382f0c8eb1a02ed43ea6

Initial commit

diff -r 000000000000 -r 50ab2f9c5b2f .hgignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,1 @@
+scratch.lisp
diff -r 000000000000 -r 50ab2f9c5b2f .lispwords
diff -r 000000000000 -r 50ab2f9c5b2f Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,4 @@
+.PHONY:
+
+quickutils.lisp: make-quickutils.lisp
+	sbcl-rlwrap --noinform --load make-quickutils.lisp  --eval '(quit)'
diff -r 000000000000 -r 50ab2f9c5b2f README.markdown
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,3 @@
+Working through [Mazes for
+Programmers](http://www.amazon.com/dp/1680500554/?tag=stelos-20) in Common Lisp
+with [Sketch](https://github.com/vydd/sketch).
diff -r 000000000000 -r 50ab2f9c5b2f make-quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/make-quickutils.lisp	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,19 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+  "quickutils.lisp"
+  :utilities '(
+               :with-gensyms
+               :once-only
+               :compose
+               :curry
+               :rcurry
+               :n-grams
+               :define-constant
+               ; :switch
+               ; :while
+               ; :ensure-boolean
+               ; :iota
+               ; :zip
+               )
+  :package "SAND.QUICKUTILS")
diff -r 000000000000 -r 50ab2f9c5b2f package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,51 @@
+(defpackage #:sand.utils
+  (:use
+    #:cl
+    #:defstar
+    #:iterate
+    #:cl-arrows
+    #:sand.quickutils)
+  (:export
+    #:zap%
+    #:%
+    #:recursively
+    #:recur
+    #:dis
+
+    #:hash-set
+    #:make-set
+    #:set-contains-p
+    #:set-add
+    #:set-remove
+    #:set-add-all
+    #:set-remove-all
+    #:set-random
+    #:set-pop
+    #:set-empty-p
+    #:set-clear
+
+    #:averaging
+    #:timing
+    #:real-time
+    #:run-time
+    #:since-start-into
+    #:per-iteration-into
+
+    #:queue
+    #:queue-contents
+    #:enqueue
+    #:dequeue
+    #:queue-empty-p
+    #:queue-append
+
+    ))
+
+(defpackage #:sand.random-numbers
+  (:use
+    #:cl
+    #:defstar
+    #:iterate
+    #:cl-arrows
+    #:sand.quickutils
+    #:sand.utils))
+
diff -r 000000000000 -r 50ab2f9c5b2f quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/quickutils.lisp	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,248 @@
+;;;; 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 :N-GRAMS :DEFINE-CONSTANT) :ensure-package T :package "SAND.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "SAND.QUICKUTILS")
+    (defpackage "SAND.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use #:cl))))
+
+(in-package "SAND.QUICKUTILS")
+
+(when (boundp '*utilities*)
+  (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
+                                         :MAKE-GENSYM-LIST :ONCE-ONLY
+                                         :ENSURE-FUNCTION :COMPOSE :CURRY
+                                         :RCURRY :TAKE :N-GRAMS
+                                         :DEFINE-CONSTANT))))
+
+  (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 take (n sequence)
+    "Take the first `n` elements from `sequence`."
+    (subseq sequence 0 n))
+  
+
+  (defun n-grams (n sequence)
+    "Find all `n`-grams of the sequence `sequence`."
+    (assert (and (plusp n)
+                 (<= n (length sequence))))
+    
+    (etypecase sequence
+      ;; Lists
+      (list (loop :repeat (1+ (- (length sequence) n))
+                  :for seq :on sequence
+                  :collect (take n seq)))
+      
+      ;; General sequences
+      (sequence (loop :for i :to (- (length sequence) n)
+                      :collect (subseq sequence i (+ i n))))))
+  
+
+  (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))))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(with-gensyms with-unique-names once-only compose curry rcurry
+            n-grams define-constant)))
+
+;;;; END OF quickutils.lisp ;;;;
diff -r 000000000000 -r 50ab2f9c5b2f sand.asd
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/sand.asd	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,22 @@
+(asdf:defsystem #:sand
+  :name "sand"
+  :description "A little sandbox to play around in."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+
+  :license "MIT/X11"
+  :version "0.0.1"
+
+  :depends-on (#:defstar
+               #:iterate
+               #:cl-arrows)
+
+  :serial t
+  :components
+  ((:file "quickutils") ; quickutils package ordering crap
+   (:file "package")
+   (:module "src"
+    :serial t
+    :components ((:file "utils")
+                 (:file "random-numbers")
+                 ))))
diff -r 000000000000 -r 50ab2f9c5b2f src/random-numbers.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/random-numbers.lisp	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,67 @@
+(in-package #:sand.random-numbers)
+
+
+(declaim (optimize (speed 1) (safety 1) (debug 3)))
+
+(deftype positive-fixnum () `(integer 1 ,most-positive-fixnum))
+(deftype negative-fixnum () `(integer ,most-negative-fixnum -1))
+(deftype nonnegative-fixnum () `(integer 1 ,most-positive-fixnum))
+(deftype nonpositive-fixnum () `(integer ,most-negative-fixnum -1))
+
+(defun* +mod ((x nonnegative-fixnum)
+              (y nonnegative-fixnum)
+              (m positive-fixnum))
+  (if (<= x (- m 1 y))
+    (+ x y)
+    (- x (- m y))))
+
+
+(defun* make-linear-congruential-rng
+    ((modulus positive-fixnum)
+     (multiplier nonnegative-fixnum)
+     (increment nonnegative-fixnum)
+     (seed nonnegative-fixnum))
+  (let ((val seed))
+    (lambda (incr)
+      (loop :repeat incr :do
+            (setf val (mod (+ (* multiplier val)
+                              increment)
+                           modulus))))))
+
+(defun* make-linear-congruential-rng-fast%
+    ((modulus positive-fixnum)
+     (multiplier nonnegative-fixnum)
+     (increment nonnegative-fixnum)
+     (seed nonnegative-fixnum))
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (let ((val seed))
+    (lambda (incr)
+      (declare (positive-fixnum incr))
+      (loop :repeat incr :do
+            (setf val (mod (+ (the nonnegative-fixnum (* multiplier val))
+                              increment)
+                           modulus))))))
+
+(define-compiler-macro make-linear-congruential-rng
+    (&whole form
+     modulus multiplier increment seed)
+  (if (and (constantp modulus)
+           (constantp multiplier)
+           (<= (* multiplier (1- modulus))
+               most-positive-fixnum))
+    `(make-linear-congruential-rng-fast% ,modulus ,multiplier ,increment ,seed)
+    form))
+
+
+(defun dammit () (make-linear-congruential-rng 50 2 3 2))
+(defparameter *r* (dammit))
+(disassemble *r*)
+
+(defparameter m 40)
+
+(defun run ()
+  (let ((r (make-linear-congruential-rng 50 2 3 2)))
+    (disassemble r)
+    (funcall r 100000000)))
+
+(time (run))
diff -r 000000000000 -r 50ab2f9c5b2f src/utils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/utils.lisp	Wed Jul 06 18:29:38 2016 +0000
@@ -0,0 +1,209 @@
+(in-package #:sand.utils)
+
+;;;; Miscellaneous
+(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 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)))))
+
+(defmacro dis (arglist &body body)
+  "Disassemble the code generated for a `lambda*` with `arglist` and `body`.
+
+  It will also spew compiler notes so you can see why the garbage box isn't
+  doing what you think it should be doing.
+
+  "
+  `(->> '(lambda* ,arglist
+          (declare (optimize speed))
+          ,@body)
+    macroexpand-1
+    (compile nil)
+    disassemble))
+
+
+;;;; Sets
+;;; Janky implementation of basic 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~^ ~}"
+            (hash-keys (slot-value set 'data)))))
+
+
+;;;; Iterate
+(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)))))))
+
+
+;;;; Queues
+;;; From PAIP (thanks, Norvig).
+
+(deftype queue () '(cons list list))
+
+(declaim (inline queue-contents make-queue
+                 enqueue dequeue
+                 queue-empty-p queue-append))
+
+
+(defun* queue-contents ((q queue))
+  (:returns list)
+  (cdr q))
+
+(defun* make-queue ()
+  (:returns queue)
+  (let ((q (cons nil nil)))
+    (setf (car q) q)))
+
+(defun* enqueue ((item t) (q queue))
+  (:returns queue)
+  (setf (car q)
+        (setf (rest (car q))
+              (cons item nil)))
+  q)
+
+(defun* dequeue ((q queue))
+  (:returns t)
+  (prog1
+      (pop (cdr q))
+    (if (null (cdr q))
+      (setf (car q) q))))
+
+(defun* queue-empty-p ((q queue))
+  (:returns boolean)
+  (null (queue-contents q)))
+
+(defun* queue-append ((q queue) (l list))
+  (:returns queue)
+  (when l
+    (setf (car q)
+          (last (setf (rest (car q))
+                      l))))
+  q)
+
+
+