# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1478955090 0
# Node ID 1b413ff8aa5f8061eb1b935a5a25fefe8da6f086
# Parent  d45bff9b6951c55909311a9c3bd057d33067e9a1
Add Polya's Urn

diff -r d45bff9b6951 -r 1b413ff8aa5f package.lisp
--- a/package.lisp	Fri Oct 14 22:51:16 2016 +0000
+++ b/package.lisp	Sat Nov 12 12:51:30 2016 +0000
@@ -1,242 +1,243 @@
 ; (rename-package :charms :hunchentoot '(:ht))
 
 
-(defpackage #:sand.utils
+(defpackage :sand.utils
   (:use
-    #:cl
-    #:losh
-    #:iterate
-    #:cl-arrows
-    #:sand.quickutils)
+    :cl
+    :losh
+    :iterate
+    :cl-arrows
+    :sand.quickutils)
   (:export
-    #:average4)
-  (:shadowing-import-from #:cl-arrows
-    #:->))
+    :average4)
+  (:shadowing-import-from :cl-arrows
+    :->))
 
-(defpackage #:sand.primes
+(defpackage :sand.primes
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.quickutils
+    :sand.utils)
   (:export
-    #:primep))
+    :primep))
 
-(defpackage #:sand.random-numbers
+(defpackage :sand.random-numbers
   (:use
-    #:cl
-    #:losh
-    #:iterate
-    #:cl-arrows
-    #:sand.quickutils
-    #:sand.utils)
-  (:shadowing-import-from #:cl-arrows
-    #:->))
+    :cl
+    :losh
+    :iterate
+    :cl-arrows
+    :sand.quickutils
+    :sand.utils)
+  (:shadowing-import-from :cl-arrows
+    :->))
 
-(defpackage #:sand.parenscript
+(defpackage :sand.parenscript
   (:use
-    #:cl
-    #:losh
-    #:sand.quickutils
-    #:cl-arrows
-    #:cl-fad
-    #:parenscript)
-  (:shadowing-import-from #:cl-arrows
-    #:->)
-  (:shadowing-import-from #:losh
-    #:%))
+    :cl
+    :losh
+    :sand.quickutils
+    :cl-arrows
+    :cl-fad
+    :parenscript)
+  (:shadowing-import-from :cl-arrows
+    :->)
+  (:shadowing-import-from :losh
+    :%))
 
-(defpackage #:sand.ascii
+(defpackage :sand.ascii
   (:use
-    #:cl
-    #:losh
-    #:iterate
-    #:cl-arrows
-    #:sand.quickutils
-    #:sand.utils))
+    :cl
+    :losh
+    :iterate
+    :cl-arrows
+    :sand.quickutils
+    :sand.utils))
 
-(defpackage #:sand.terrain.diamond-square
+(defpackage :sand.terrain.diamond-square
   (:use
-    #:cl
-    #:losh
-    #:iterate
-    #:cl-arrows
-    #:sand.quickutils
-    #:sand.utils))
+    :cl
+    :losh
+    :iterate
+    :cl-arrows
+    :sand.quickutils
+    :sand.utils))
 
-(defpackage #:sand.sketch
+(defpackage :sand.sketch
   (:use
-    #:cl
-    #:losh
-    #:sketch
-    #:iterate
-    #:sand.quickutils
-    #:sand.utils)
-  (:shadowing-import-from #:iterate
-    #:in)
-  (:shadowing-import-from #:sketch
-    #:degrees
-    #:radians))
+    :cl
+    :losh
+    :sketch
+    :iterate
+    :sand.quickutils
+    :sand.utils)
+  (:shadowing-import-from :iterate
+    :in)
+  (:shadowing-import-from :sketch
+    :degrees
+    :radians))
 
-(defpackage #:sand.markov
+(defpackage :sand.markov
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:split-sequence
-    #:sand.quickutils
-    #:sand.utils))
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :split-sequence
+    :sand.quickutils
+    :sand.utils))
 
-(defpackage #:sand.dijkstra-maps
+(defpackage :sand.dijkstra-maps
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.quickutils
+    :sand.utils)
   (:export
-    #:dijkstra-map
-    #:make-dijkstra-map
-    #:dm-maximum-value
-    #:dm-map
-    #:dm-ref))
+    :dijkstra-map
+    :make-dijkstra-map
+    :dm-maximum-value
+    :dm-map
+    :dm-ref))
 
-(defpackage #:sand.graphs
+(defpackage :sand.graphs
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.quickutils
+    :sand.utils)
   (:export
     ))
 
-(defpackage #:sand.graphviz
+(defpackage :sand.graphviz
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.quickutils
+    :sand.utils)
   (:export
-    #:graphviz-digraph))
+    :graphviz-digraph))
 
-(defpackage #:sand.binary-decision-diagrams
+(defpackage :sand.binary-decision-diagrams
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.graphviz
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.graphviz
+    :sand.quickutils
+    :sand.utils)
   (:export
     ))
 
-(defpackage #:sand.zero-suppressed-decision-diagrams
+(defpackage :sand.zero-suppressed-decision-diagrams
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.graphviz
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.graphviz
+    :sand.quickutils
+    :sand.utils)
   (:export
     )
-  (:nicknames #:sand.zdd))
+  (:nicknames :sand.zdd))
 
-(defpackage #:sand.huffman-trees
+(defpackage :sand.huffman-trees
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.graphviz
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.graphviz
+    :sand.quickutils
+    :sand.utils)
   (:export
     ))
 
-(defpackage #:sand.rubiks
+(defpackage :sand.streams
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.quickutils
-    #:sand.utils)
-  (:export
-    ))
-
-(defpackage #:sand.streams
-  (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.primes
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.primes
+    :sand.quickutils
+    :sand.utils)
   (:export
     ))
 
 #+sbcl
-(defpackage #:sand.ffi
+(defpackage :sand.ffi
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:cffi
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :cffi
+    :sand.quickutils
+    :sand.utils)
   (:export
     ))
 
-(defpackage #:sand.color-difference
+(defpackage :sand.color-difference
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:rs-colors
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :rs-colors
+    :sand.quickutils
+    :sand.utils)
   (:export
     ))
 
 
 #+sbcl
-(defpackage #:sand.profiling
+(defpackage :sand.profiling
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.quickutils
+    :sand.utils)
   (:export
-    #:start-profiling
-    #:stop-profiling
-    #:profile))
+    :start-profiling
+    :stop-profiling
+    :profile))
 
 
-(defpackage #:sand.number-letters
+(defpackage :sand.number-letters
   (:use
-    #:cl
-    #:cl-arrows
-    #:losh
-    #:iterate
-    #:function-cache
-    #:sand.quickutils
-    #:sand.utils)
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :function-cache
+    :sand.quickutils
+    :sand.utils)
   (:export
     ))
 
+(defpackage :sand.urn
+  (:use
+    :cl
+    :cl-arrows
+    :losh
+    :iterate
+    :sand.quickutils
+    :sand.utils)
+  (:export
+    ))
+
+
diff -r d45bff9b6951 -r 1b413ff8aa5f sand.asd
--- a/sand.asd	Fri Oct 14 22:51:16 2016 +0000
+++ b/sand.asd	Sat Nov 12 12:51:30 2016 +0000
@@ -41,6 +41,7 @@
                  (:file "primes")
                  (:file "graphs")
                  (:file "graphviz")
+                 (:file "urn")
                  (:file "random-numbers")
                  (:file "ascii")
                  (:file "markov")
@@ -53,7 +54,6 @@
                  (:file "streams")
                  (:file "color-difference")
                  (:file "number-letters")
-                 (:file "rubiks")
                  (:module "terrain"
                   :serial t
                   :components ((:file "diamond-square")))
diff -r d45bff9b6951 -r 1b413ff8aa5f src/rubiks.lisp
--- a/src/rubiks.lisp	Fri Oct 14 22:51:16 2016 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,118 +0,0 @@
-(in-package #:sand.rubiks)
-
-; (declaim (optimize (speed 1) (safety 3) (debug 3)))
-
-(deftype cube () '(simple-array t (6 9)))
-
-(defun make-solved-cube ()
-  (make-array '(6 9)
-    :adjustable nil
-    ; :element-type 'symbol
-    :initial-contents
-    '((w w w w w w w w w) ; top
-      (g g g g g g g g g) ; left
-      (r r r r r r r r r) ; front
-      (b b b b b b b b b) ; right
-      (o o o o o o o o o) ; back
-      (y y y y y y y y y)))) ; down
-
-
-(defun face-index (face)
-  (case face
-    (:top 0)
-    (:left 1)
-    (:front 2)
-    (:right 3)
-    (:back 4)
-    (:down 5)))
-
-
-(defmacro defaccessor (name face)
-  `(defmacro ,name (cube n)
-    `(aref ,cube ,(face-index ,face) ,n)))
-
-
-(defaccessor top :top)
-(defaccessor down :down)
-(defaccessor left :left)
-(defaccessor right :right)
-(defaccessor front :front)
-(defaccessor back :back)
-
-(defmacro define-move (name &rest groups)
-  (flet ((access (spec)
-           `(,(first spec) cube ,(second spec))))
-    `(progn
-      (declaim (ftype (function (cube) null) ,name))
-      (defun ,name (cube)
-        ,@(mapcar (lambda (group)
-                    `(rotatef ,@(mapcar #'access group)))
-                  groups)
-        nil))))
-
-;       0 1 2
-;       3 4 5
-;       6 7 8
-; 0 1 2 0 1 2 0 1 2 0 1 2
-; 3 4 5 3 4 5 3 4 5 3 4 5
-; 6 7 8 6 7 8 6 7 8 6 7 8
-;       0 1 2
-;       3 4 5
-;       6 7 8
-
-(define-move move-front
-  ((front 0) (front 6) (front 8) (front 2))
-  ((front 1) (front 3) (front 7) (front 5))
-  ((top 6) (left 8) (down 2) (right 0))
-  ((top 7) (left 5) (down 1) (right 3))
-  ((top 8) (left 2) (down 0) (right 6)))
-
-(define-move move-top
-  ((top 0) (top 6) (top 8) (top 2))
-  ((top 1) (top 3) (top 7) (top 5))
-  ((front 0) (right 0) (back 0) (left 0))
-  ((front 1) (right 1) (back 1) (left 1))
-  ((front 2) (right 2) (back 2) (left 2)))
-
-(define-move move-left
-  ((left 0) (left 6) (left 8) (left 2))
-  ((left 1) (left 3) (left 7) (left 5))
-  ((front 0) (top 0) (back 2) (down 0))
-  ((front 3) (top 3) (back 5) (down 3))
-  ((front 6) (top 6) (back 8) (down 6)))
-
-(define-move move-right
-  ((right 0) (right 6) (right 8) (right 2))
-  ((right 1) (right 3) (right 7) (right 5))
-  ((front 2) (down 2) (back 8) (top 2))
-  ((front 5) (down 5) (back 5) (top 5))
-  ((front 8) (down 8) (back 2) (top 8)))
-
-
-
-(defun print-cube (cube)
-  (flet ((pad ()
-           (format t "      "))
-         (row (face row)
-           (format t "~A ~A ~A "
-                   (aref cube (face-index face) (+ 0 (* row 3)))
-                   (aref cube (face-index face) (+ 1 (* row 3)))
-                   (aref cube (face-index face) (+ 2 (* row 3))))))
-    (pad) (row :top 0) (terpri)
-    (pad) (row :top 1) (terpri)
-    (pad) (row :top 2) (terpri)
-    (row :left 0) (row :front 0) (row :right 0) (row :back 0) (terpri)
-    (row :left 1) (row :front 1) (row :right 1) (row :back 1) (terpri)
-    (row :left 2) (row :front 2) (row :right 2) (row :back 2) (terpri)
-    (pad) (row :down 0) (terpri)
-    (pad) (row :down 1) (terpri)
-    (pad) (row :down 2) (terpri))
-  (values))
-
-
-(defparameter *c* (make-solved-cube))
-; (move-front *c*)
-; (move-top *c*)
-; (move-left *c*)
-; (move-right *c*)
-; (print-cube *c*)
diff -r d45bff9b6951 -r 1b413ff8aa5f src/urn.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/urn.lisp	Sat Nov 12 12:51:30 2016 +0000
@@ -0,0 +1,52 @@
+(in-package :sand.urn)
+
+(defun make-vec-from (contents)
+  (make-array (length contents)
+    :initial-contents contents
+    :fill-pointer (length contents)
+    :adjustable t))
+
+(defun make-empty-vec (size)
+  (make-array size
+    :fill-pointer 0
+    :adjustable t))
+
+
+(defun sample (population size)
+  (let ((result (make-empty-vec size)))
+    (dotimes (_ size)
+      (vector-push-extend (random-elt population) result))
+    result))
+
+(defun unsample (sample target-size)
+  (recursively ((sample sample))
+    (if (= (length sample) target-size)
+      sample
+      (progn (vector-push-extend (random-elt sample) sample)
+             (recur sample)))))
+
+
+
+(defparameter *population*
+  (make-vec-from
+    (append (make-list 1000 :initial-element 'a)
+            (make-list 3000 :initial-element 'b)
+            (make-list 500 :initial-element 'c))))
+
+
+; (print-hash-table (frequencies *population*))
+; (print-hash-table (proportions *population* :float t))
+
+; (-<> *population*
+;   (sample <> 100)
+;   (unsample <> 1000)
+;   (proportions <> :float t)
+;   (print-hash-table <>)
+;   )
+
+; (-<> *population*
+;   (sample <> 100)
+;   (proportions <> :float nil)
+;   (print-hash-table <>)
+;   )
+