--- 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
--- 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")
--- 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)))))
--- /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))))
+
+
--- 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)
--- /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 *)