# HG changeset patch # User Steve Losh # Date 1476479754 0 # Node ID 833316fc5296646c59413d937ac46a48c453b774 # Parent d2c07bcc6144cff2c85a92158702dee3808fc343 Add a bunch of stuff from the past month or two... diff -r d2c07bcc6144 -r 833316fc5296 package.lisp --- a/package.lisp Thu Sep 15 14:23:13 2016 +0000 +++ b/package.lisp Fri Oct 14 21:15:54 2016 +0000 @@ -75,7 +75,10 @@ #:sand.quickutils #:sand.utils) (:shadowing-import-from #:iterate - #:in)) + #:in) + (:shadowing-import-from #:sketch + #:degrees + #:radians)) (defpackage #:sand.markov (:use @@ -102,6 +105,17 @@ #:dm-map #:dm-ref)) +(defpackage #:sand.graphs + (:use + #:cl + #:cl-arrows + #:losh + #:iterate + #:sand.quickutils + #:sand.utils) + (:export + )) + (defpackage #:sand.graphviz (:use #:cl @@ -125,6 +139,19 @@ (:export )) +(defpackage #:sand.zero-suppressed-decision-diagrams + (:use + #:cl + #:cl-arrows + #:losh + #:iterate + #:sand.graphviz + #:sand.quickutils + #:sand.utils) + (:export + ) + (:nicknames #:sand.zdd)) + (defpackage #:sand.huffman-trees (:use #:cl diff -r d2c07bcc6144 -r 833316fc5296 sand.asd --- a/sand.asd Thu Sep 15 14:23:13 2016 +0000 +++ b/sand.asd Fri Oct 14 21:15:54 2016 +0000 @@ -39,6 +39,7 @@ :serial t :components ((:file "utils") (:file "primes") + (:file "graphs") (:file "graphviz") (:file "random-numbers") (:file "ascii") @@ -47,6 +48,7 @@ #+sbcl (:file "ffi") #+sbcl (:file "profiling") (:file "binary-decision-diagrams") + (:file "zero-suppressed-decision-diagrams") (:file "huffman-trees") (:file "streams") (:file "color-difference") diff -r d2c07bcc6144 -r 833316fc5296 src/ascii.lisp --- a/src/ascii.lisp Thu Sep 15 14:23:13 2016 +0000 +++ b/src/ascii.lisp Fri Oct 14 21:15:54 2016 +0000 @@ -110,8 +110,11 @@ (negatef (getf *ball* :vx))) (setf (getf *ball* :y) (truncate (/ *height* 2)))) +(defparameter *input* nil) (defun handle-input () (let ((input (charms:get-char charms:*standard-window* :ignore-error t))) + (when input + (push input *input*)) (case input ((nil) nil) (#\q (setf *running* nil))))) diff -r d2c07bcc6144 -r 833316fc5296 src/graphs.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/graphs.lisp Fri Oct 14 21:15:54 2016 +0000 @@ -0,0 +1,115 @@ +(in-package #:sand.graphs) + + +(defun make-edge (from to) + (cons from to)) + +(defun edge-from (edge) + (car edge)) + +(defun edge-to (edge) + (cdr edge)) + +(defun edge= (test e1 e2) + (and (funcall test (edge-from e1) (edge-from e2)) + (funcall test (edge-to e1) (edge-to e2)))) + + +(defclass directed-graph () + ((edges :initarg :edges :accessor digraph-edges) + (nodes :initarg :nodes :accessor digraph-nodes) + (node-test :initarg :node-test :accessor digraph-node-test) + (edge-test :initarg :edge-test :accessor digraph-edge-test))) + +(defun make-directed-graph (&key (test #'eql)) + (make-instance 'directed-graph + :node-test test + :edge-test (curry #'edge= test) + :nodes nil + :edges nil)) + + +(defun digraph-node= (digraph o1 o2) + (funcall (digraph-node-test digraph) o1 o2)) + +(defun digraph-edge= (digraph e1 e2) + (funcall (digraph-edge-test digraph) e1 e2)) + + +(defun digraph-map-nodes (function digraph) + (mapcar function (digraph-nodes digraph))) + +(defun digraph-map-edges (function digraph) + (iterate (for edge :in (digraph-edges digraph)) + (collect (funcall function (edge-from edge) (edge-to edge))))) + +(defun digraph-filter-edges (predicate digraph &key (key 'identity)) + (remove-if-not predicate (digraph-edges digraph) :key key)) + + +(defun digraph-edges-from (digraph object) + (digraph-filter-edges (curry #'digraph-node= digraph object) + digraph + :key #'edge-from)) + +(defun digraph-edges-to (digraph object) + (digraph-filter-edges (curry #'digraph-node= digraph object) + digraph + :key #'edge-to)) + +(defun digraph-edges-involving (digraph object) + (digraph-filter-edges (lambda (edge) + (or (digraph-node= digraph object (edge-from edge)) + (digraph-node= digraph object (edge-to edge)))) + digraph)) + + +(defun digraph-successors (digraph object) + (mapcar #'edge-to (digraph-edges-from digraph object))) + +(defun digraph-predecessors (digraph object) + (mapcar #'edge-from (digraph-edges-to digraph object))) + +(defun digraph-map-successors (function digraph object) + (mapcar function (digraph-successors digraph object))) + +(defun digraph-map-predecessors (function digraph object) + (mapcar function (digraph-predecessors digraph object))) + + +(defun digraph-add-node (digraph object) + (zapf (digraph-nodes digraph) + (adjoin object % :test (digraph-node-test digraph)))) + +(defun digraph-add-edge (digraph from to) + (zapf (digraph-edges digraph) + (adjoin (make-edge from to) % + :test (digraph-edge-test digraph)))) + +(defun digraph-remove-node (digraph object) + (zapf (digraph-nodes digraph) + (remove object % :test (digraph-node-test digraph)) + (digraph-edges digraph) + (set-difference % (digraph-edges-involving digraph object) + :test (digraph-edge-test digraph))) + nil) + +(defun digraph-remove-edge (digraph from to) + (zapf (digraph-edges digraph) + (remove (make-edge from to) % + :test (digraph-edge-test digraph))) + nil) + + +(defmethod print-object ((digraph directed-graph) stream) + (print-unreadable-object (digraph stream :type t :identity t) + (when (not (null (digraph-nodes digraph))) + (terpri stream) + (digraph-map-nodes + (lambda (node) + (format stream " ~S -> ~S~%" + node + (mapcar #'edge-to (digraph-edges-from digraph node)))) + digraph)))) + + diff -r d2c07bcc6144 -r 833316fc5296 src/number-letters.lisp --- a/src/number-letters.lisp Thu Sep 15 14:23:13 2016 +0000 +++ b/src/number-letters.lisp Fri Oct 14 21:15:54 2016 +0000 @@ -2,8 +2,6 @@ ; https://www.youtube.com/watch?v=LYKn0yUTIU4 -(declaim (optimize (debug 0) (safety 1) (speed 3))) - ;;;; Slow/Reference Implementation -------------------------------------------- (defun number-string (n) @@ -14,7 +12,7 @@ ;;;; Fast Version ------------------------------------------------------------- -(define-constant +small-counts+ +(defparameter *small-counts* (make-array 1000 :element-type 'fixnum :initial-contents (iterate (for i :from 0 :below 1000) @@ -25,8 +23,7 @@ (iterate (for i :from 1 :to 21) (collect (subseq (format nil "~R" (expt 1000 i)) 4))))) -(define-constant +suffix-lengths+ (mapcar #'length *suffixes*) - :test #'equal) +(defparameter *suffix-lengths* (mapcar #'length *suffixes*)) (declaim (ftype (function ((integer 0)) fixnum) @@ -37,12 +34,12 @@ 4 (iterate (for i :first n :then (floor i 1000)) - (for sl :in +suffix-lengths+) + (for sl :in *suffix-lengths*) (while (not (zerop i))) (for part = (mod i 1000)) (when (not (zerop part)) (sum sl) - (sum (aref +small-counts+ part)))))) + (sum (aref *small-counts* part)))))) (defun sanity-check () (iterate (for i :from 1 :to 10000000) @@ -63,11 +60,11 @@ (print-chain lc)))) -(define-constant +cache-size+ 1000) -(define-constant +cache+ - (make-array +cache-size+ +(defparameter *cache-size* 1000) +(defparameter *cache* + (make-array *cache-size* :element-type 'fixnum - :initial-contents (iterate (for i :from 0 :below +cache-size+) + :initial-contents (iterate (for i :from 0 :below *cache-size*) (collect (chain-length i))))) (defun chain-length% (n) @@ -75,8 +72,8 @@ (for i :first n :then (fast-letter-count i)) (summing 1 :into result) (declare (type fixnum result)) - (when (< i +cache-size+) - (return (the fixnum (+ result (aref +cache+ i))))))) + (when (< i *cache-size*) + (return (the fixnum (* result (aref *cache+ i))))))) (defun longest-chain (max) diff -r d2c07bcc6144 -r 833316fc5296 src/zero-suppressed-decision-diagrams.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/zero-suppressed-decision-diagrams.lisp Fri Oct 14 21:15:54 2016 +0000 @@ -0,0 +1,84 @@ +(in-package #:sand.zero-suppressed-decision-diagrams) + +(adt:defdata zdd + empty + unit + (node t zdd zdd)) + + +(defun zdd-with (element) + (node element empty unit)) + +(defun patch-unit (z) + (adt:match zdd z + (empty unit) + (unit unit) + ((node element low high) + (node element (patch-unit low) high)))) + +(defun zdd-union (z1 z2 &key (test #'<)) + (recursively ((z1 z1) (z2 z2)) + (adt:match zdd z1 + (empty z2) + (unit (patch-unit z2)) + ((node e1 l1 h1) (adt:match zdd z2 + (empty z1) + (unit (patch-unit z1)) + ((node e2 l2 h2) + (cond + ((funcall test e1 e2) (node e1 (recur l1 z2) h1)) + ((funcall test e2 e1) (recur z2 z1)) + (t (node e1 (recur l1 l2) (recur h1 h2)))))))))) + +(defun zdd-adjoin (z element &key (test #'<)) + (recursively ((z z)) + (adt:match zdd z + (empty empty) + (unit (node element empty unit)) + ((node e low high) + (cond ((funcall test element e) + (node element empty z)) + ((funcall test e element) + (node e (recur low) (recur high))) + (t + (node element empty (zdd-union low high :test test)))))))) + +(defun zdd-disjoin (z element &key (test #'<)) + (recursively ((z z)) + (adt:match zdd z + (empty empty) + (unit unit) + ((node e low high) + (cond ((funcall test element e) + z) + ((funcall test e element) + (node e (recur low) (recur high))) + (t + (zdd-union low high :test test))))))) + + +(defun enumerate-zdd (zdd) + (adt:match zdd zdd + (empty nil) + (unit (list nil)) + ((node element low high) + (append (mapcar (lambda (s) (cons element s)) + (enumerate-zdd high)) + (enumerate-zdd low))))) + + +(zdd-union (zdd-union (zdd-with 2) (zdd-with 1)) + (zdd-adjoin + (zdd-union (zdd-union (zdd-with 2) (zdd-with 3)) + (zdd-union (zdd-with 1) (zdd-with 3))) + 2)) + +(zdd-adjoin + (zdd-union (zdd-union (zdd-with 2) (zdd-with 3)) + (zdd-union (zdd-with 1) (zdd-with 3))) + 2) + +(zdd-disjoin * 2) + + +(enumerate-zdd *)