--- a/.lispwords Tue Nov 22 19:35:37 2016 +0000
+++ b/.lispwords Wed Dec 07 15:12:32 2016 -0500
@@ -2,3 +2,4 @@
(1 recursively)
(1 just-once)
(1 bdd-case)
+(1 sanity-check)
--- a/package.lisp Tue Nov 22 19:35:37 2016 +0000
+++ b/package.lisp Wed Dec 07 15:12:32 2016 -0500
@@ -145,6 +145,27 @@
(:export
:graphviz-digraph))
+(defpackage :sand.ropes
+ (:use
+ :cl
+ :cl-arrows
+ :losh
+ :iterate
+ :trivia
+ :sand.quickutils
+ :sand.utils)
+ (:export
+ ))
+
+(defpackage :sand.hanoi
+ (:use
+ :cl
+ :losh
+ :sand.quickutils
+ :sand.utils)
+ (:export
+ ))
+
(defpackage :sand.binary-decision-diagrams
(:use
:cl
--- a/sand.asd Tue Nov 22 19:35:37 2016 +0000
+++ b/sand.asd Wed Dec 07 15:12:32 2016 -0500
@@ -23,6 +23,7 @@
:html-entities
:iterate
:losh
+ :trivia
:parenscript
:plump
:rs-colors
@@ -45,9 +46,11 @@
(:file "primes")
(:file "graphs")
(:file "graphviz")
+ (:file "hanoi")
(:file "urn")
(:file "random-numbers")
(:file "generic-arithmetic")
+ (:file "ropes")
(:file "sorting")
(:file "ascii")
(:file "markov")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/hanoi.lisp Wed Dec 07 15:12:32 2016 -0500
@@ -0,0 +1,16 @@
+(in-package :sand.hanoi)
+
+(defun move (disc from to)
+ (format t "Move disc ~D from ~D to ~D~%" disc from to))
+
+(defun hanoi (n)
+ (recursively ((disc n)
+ (from 1)
+ (to 3)
+ (using 2))
+ (when (plusp disc)
+ (recur (1- disc) from using to)
+ (move disc from to)
+ (recur (1- disc) using to from)))
+ (values))
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/ropes.lisp Wed Dec 07 15:12:32 2016 -0500
@@ -0,0 +1,187 @@
+(in-package :sand.ropes)
+
+;;;; De-crazifying Trivia's struct pattern matching
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun struct% (name vars-and-accessors)
+ (with-gensyms (instance)
+ `(guard1
+ (,instance :type ,name) (typep ,instance ',name)
+ ,@(iterate (for (var accessor) :in vars-and-accessors)
+ (unless (string= (symbol-name var) "_")
+ (collect `(,accessor ,instance))
+ (collect `(guard1 ,var t)))))))
+
+ (defun find-accessors (name-and-options slots-and-vars)
+ (destructuring-bind
+ (name &key (conc-name (symb name '-)))
+ name-and-options
+ (iterate (for (slot var) :in slots-and-vars)
+ (for accessor = (symb conc-name slot))
+ (collect (list var accessor))))))
+
+(defpattern struct (name-and-options &rest slots)
+ (let ((name-and-options (ensure-list name-and-options)))
+ (struct%
+ (first name-and-options)
+ (when slots
+ (etypecase (first slots)
+ (keyword (find-accessors name-and-options (subdivide slots 2)))
+ (symbol (find-accessors name-and-options (mapcar #'list slots slots)))
+ (cons slots))))))
+
+
+;;;; Ropes --------------------------------------------------------------------
+(deftype rope ()
+ '(or simple-string concat))
+
+(deftype non-negative-fixnum ()
+ `(integer 0 ,most-positive-fixnum))
+
+(deftype array-index ()
+ `(integer 0 ,array-dimension-limit))
+
+
+(defstruct (concat (:constructor make-concat%))
+ (size 0 :type non-negative-fixnum :read-only t)
+ (left-size 0 :type non-negative-fixnum :read-only t)
+ (left nil :type rope :read-only t)
+ (right nil :type (or null rope) :read-only t))
+
+(defpattern concat (size left-size left right)
+ `(struct concat :size ,size :left-size ,left-size :left ,left :right ,right))
+
+
+(declaim (ftype (function (*) array-index) size))
+
+(defun-ematch size (rope)
+ ((type simple-string) (length rope))
+ ((concat size _ _ _) size))
+
+(defun minimalp (left right)
+ (and (typep left 'simple-string)
+ (typep right 'simple-string)
+ (< (+ (length left)
+ (length right))
+ 25)
+ t))
+
+(defun make-concat (left right)
+ (cond ((equal right "") left)
+ ((equal left "") right)
+ ((minimalp left right) (concatenate 'string left right))
+ (t (make-concat% :size (+ (size left) (size right))
+ :left-size (size left)
+ :left left
+ :right right))))
+
+
+(defmacro sanity-check ((rope &optional indexes char)
+ &body body)
+ `(progn
+ (check-type ,rope rope)
+ ,@(when char
+ `((check-type ,char character)))
+ ,@(when indexes
+ (mapcar (lambda (i) `(check-type ,i array-index))
+ indexes))
+ (locally
+ (declare (type rope ,rope)
+ ,@(when indexes `((type array-index ,@indexes)))
+ ,@(when char `((type character ,char))))
+ ,@(mapcar (lambda (i) `(assert (< ,i (size ,rope))
+ (,rope ,i)
+ "Index ~D is out of bounds for rope ~S"
+ ,i ,rope))
+ indexes)
+ ,@body)))
+
+
+;;;; Lookup
+(declaim (ftype (function (rope array-index) (values character &optional))
+ lookup%))
+(defun lookup% (rope index)
+ ; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (ematch rope
+ ((type simple-string)
+ (aref rope index))
+
+ ((concat _ left-size left right)
+ (if (< index left-size)
+ (lookup% left index)
+ (lookup% right (- index left-size))))))
+
+(defun lookup (rope index)
+ (sanity-check (rope (index))
+ (lookup% rope index)))
+
+
+;;;; Set
+(defun set-char% (rope index new-char)
+ (ematch rope
+ ((type string) (let ((result (copy-seq rope)))
+ (setf (aref result index) new-char)
+ result))
+ ((concat _ left-size left right)
+ (if (< index left-size)
+ (make-concat (set-char left index new-char)
+ right)
+ (make-concat left
+ (set-char right (- index left-size) new-char))))))
+
+(defun set-char (rope index new-char)
+ (sanity-check (rope (index) new-char)
+ (set-char% rope index new-char)))
+
+
+;;;; Concat
+(defun rope-concat (left right)
+ (sanity-check (left)
+ (sanity-check (right)
+ (make-concat left right))))
+
+
+;;;; Substring
+(declaim (ftype (function (rope array-index array-index)
+ (values rope &optional))
+ rope-substring%))
+
+(defun rope-substring% (rope start end)
+ ; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (etypecase rope
+ (simple-string (subseq rope start end))
+ (concat (let ((ls (concat-left-size rope)))
+ (cond ((< end ls) (rope-substring% (concat-left rope)
+ start
+ end))
+ ((>= start ls) (rope-substring% (concat-right rope)
+ (- start ls)
+ (- end ls)))
+ (t (make-concat
+ (rope-substring% (concat-left rope) start ls)
+ (rope-substring% (concat-right rope) 0 (- end ls)))))))))
+
+(defun rope-substring (rope start end)
+ (sanity-check (rope (start end))
+ (rope-substring% rope start end)))
+
+
+;;;; Stringifying
+(declaim (ftype (function (rope) (values simple-string &optional))
+ rope-to-string%))
+
+(defun rope-to-string% (rope)
+ (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (ematch rope
+ ((type simple-string) rope)
+ ((concat _ _ left right)
+ (concatenate 'string
+ (rope-to-string% left)
+ (rope-to-string% right)))))
+
+(defun rope-to-string (rope)
+ (sanity-check (rope)
+ (rope-to-string% rope)))
+
+
+;;;; Scratch
+(defparameter *r* (rope-concat "foo" "bar"))
--- a/vendor/make-quickutils.lisp Tue Nov 22 19:35:37 2016 +0000
+++ b/vendor/make-quickutils.lisp Wed Dec 07 15:12:32 2016 -0500
@@ -8,6 +8,7 @@
:curry
:define-constant
:ensure-gethash
+ :ensure-list
:hash-table-alist
:hash-table-keys
:hash-table-plist
@@ -18,6 +19,7 @@
:read-file-into-string
:required-argument
:riffle
+ :subdivide
:symb
:tree-collect
:with-gensyms
--- a/vendor/quickutils.lisp Tue Nov 22 19:35:37 2016 +0000
+++ b/vendor/quickutils.lisp Wed Dec 07 15:12:32 2016 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SAND.QUICKUTILS")
@@ -15,16 +15,16 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :CURRY :DEFINE-CONSTANT
- :ENSURE-GETHASH :HASH-TABLE-ALIST
- :MAPHASH-KEYS :HASH-TABLE-KEYS
- :HASH-TABLE-PLIST :MAPHASH-VALUES
- :HASH-TABLE-VALUES :TAKE :N-GRAMS
- :ONCE-ONLY :RCURRY :WITH-OPEN-FILE*
- :WITH-INPUT-FROM-FILE
+ :ENSURE-GETHASH :ENSURE-LIST
+ :HASH-TABLE-ALIST :MAPHASH-KEYS
+ :HASH-TABLE-KEYS :HASH-TABLE-PLIST
+ :MAPHASH-VALUES :HASH-TABLE-VALUES
+ :TAKE :N-GRAMS :ONCE-ONLY :RCURRY
+ :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE
:READ-FILE-INTO-STRING
- :REQUIRED-ARGUMENT :RIFFLE :MKSTR
- :SYMB :TREE-COLLECT :STRING-DESIGNATOR
- :WITH-GENSYMS))))
+ :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE
+ :MKSTR :SYMB :TREE-COLLECT
+ :STRING-DESIGNATOR :WITH-GENSYMS))))
(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`,
@@ -145,6 +145,13 @@
(values (setf (gethash ,key ,hash-table) ,default) nil))))
+ (defun ensure-list (list)
+ "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
+ (if (listp list)
+ list
+ (list list)))
+
+
(defun hash-table-alist (table)
"Returns an association list containing the keys and values of hash table
`table`."
@@ -338,6 +345,28 @@
:collect obj))
+ (defun subdivide (sequence chunk-size)
+ "Split `sequence` into subsequences of size `chunk-size`."
+ (check-type sequence sequence)
+ (check-type chunk-size (integer 1))
+
+ (etypecase sequence
+ ;; Since lists have O(N) access time, we iterate through manually,
+ ;; collecting each chunk as we pass through it. Using SUBSEQ would
+ ;; be O(N^2).
+ (list (loop :while sequence
+ :collect
+ (loop :repeat chunk-size
+ :while sequence
+ :collect (pop sequence))))
+
+ ;; For other sequences like strings or arrays, we can simply chunk
+ ;; by repeated SUBSEQs.
+ (sequence (loop :with len := (length sequence)
+ :for i :below len :by chunk-size
+ :collect (subseq sequence i (min len (+ chunk-size i)))))))
+
+
(defun mkstr (&rest args)
"Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
@@ -418,9 +447,9 @@
`(with-gensyms ,names ,@forms))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose curry define-constant ensure-gethash hash-table-alist
- hash-table-keys hash-table-plist hash-table-values n-grams
- once-only rcurry read-file-into-string required-argument riffle
- symb tree-collect with-gensyms with-unique-names)))
+ (export '(compose curry define-constant ensure-gethash ensure-list
+ hash-table-alist hash-table-keys hash-table-plist hash-table-values
+ n-grams once-only rcurry read-file-into-string required-argument
+ riffle subdivide symb tree-collect with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;