# HG changeset patch # User Steve Losh # Date 1481141552 18000 # Node ID 09407f2a9764ec5ef33a7628dc7fd0889bd09200 # Parent 9f549a9639ca566b87545e01041817ee3ac5c0c3 A few more things diff -r 9f549a9639ca -r 09407f2a9764 .lispwords --- 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) diff -r 9f549a9639ca -r 09407f2a9764 package.lisp --- 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 diff -r 9f549a9639ca -r 09407f2a9764 sand.asd --- 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") diff -r 9f549a9639ca -r 09407f2a9764 src/hanoi.lisp --- /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)) + diff -r 9f549a9639ca -r 09407f2a9764 src/ropes.lisp --- /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")) diff -r 9f549a9639ca -r 09407f2a9764 vendor/make-quickutils.lisp --- 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 diff -r 9f549a9639ca -r 09407f2a9764 vendor/quickutils.lisp --- 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 ;;;;