# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1473949393 0
# Node ID d2c07bcc6144cff2c85a92158702dee3808fc343
# Parent  5c8d604c6f01200b918429c84276ed1793c0106f
Add number chains

diff -r 5c8d604c6f01 -r d2c07bcc6144 package.lisp
--- a/package.lisp	Thu Sep 15 14:22:08 2016 +0000
+++ b/package.lisp	Thu Sep 15 14:23:13 2016 +0000
@@ -174,3 +174,31 @@
   (:export
     ))
 
+
+#+sbcl
+(defpackage #:sand.profiling
+  (:use
+    #:cl
+    #:cl-arrows
+    #:losh
+    #:iterate
+    #:sand.quickutils
+    #:sand.utils)
+  (:export
+    #:start-profiling
+    #:stop-profiling
+    #:profile))
+
+
+(defpackage #:sand.number-letters
+  (:use
+    #:cl
+    #:cl-arrows
+    #:losh
+    #:iterate
+    #:function-cache
+    #:sand.quickutils
+    #:sand.utils)
+  (:export
+    ))
+
diff -r 5c8d604c6f01 -r d2c07bcc6144 sand.asd
--- a/sand.asd	Thu Sep 15 14:22:08 2016 +0000
+++ b/sand.asd	Thu Sep 15 14:23:13 2016 +0000
@@ -16,6 +16,7 @@
                #:sketch
                #:losh
                #:drakma
+               #:function-cache
                #:yason
                #:flexi-streams
                #:sanitize
@@ -25,6 +26,7 @@
                #:cl-algebraic-data-type
                #:rs-colors
                #:cffi
+               #+sbcl #:sb-sprof
                )
 
   :serial t
@@ -43,10 +45,12 @@
                  (:file "markov")
                  (:file "dijkstra-maps")
                  #+sbcl (:file "ffi")
+                 #+sbcl (:file "profiling")
                  (:file "binary-decision-diagrams")
                  (:file "huffman-trees")
                  (:file "streams")
                  (:file "color-difference")
+                 (:file "number-letters")
                  (:module "terrain"
                   :serial t
                   :components ((:file "diamond-square")))
diff -r 5c8d604c6f01 -r d2c07bcc6144 src/number-letters.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/number-letters.lisp	Thu Sep 15 14:23:13 2016 +0000
@@ -0,0 +1,90 @@
+(in-package #:sand.number-letters)
+
+; https://www.youtube.com/watch?v=LYKn0yUTIU4
+
+(declaim (optimize (debug 0) (safety 1) (speed 3)))
+
+
+;;;; Slow/Reference Implementation --------------------------------------------
+(defun number-string (n)
+  (format nil "~R" n))
+
+(defun slow-letter-count (n)
+  (count-if #'alpha-char-p (number-string n)))
+
+
+;;;; Fast Version -------------------------------------------------------------
+(define-constant +small-counts+
+  (make-array 1000
+    :element-type 'fixnum
+    :initial-contents (iterate (for i :from 0 :below 1000)
+                               (collect (slow-letter-count i)))))
+
+(defparameter *suffixes*
+  (cons ""
+        (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)
+
+
+(declaim (ftype (function ((integer 0)) fixnum)
+                fast-letter-count))
+(defun fast-letter-count (n)
+  (declare (optimize (debug 0) (safety 0) (speed 3)))
+  (if (zerop n)
+    4
+    (iterate
+      (for i :first n :then (floor i 1000))
+      (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))))))
+
+(defun sanity-check ()
+  (iterate (for i :from 1 :to 10000000)
+           (finding i :such-that (not (= (fast-letter-count i)
+                                         (slow-letter-count i))))))
+
+
+;;;; Chains -------------------------------------------------------------------
+(defun chain-length (n)
+  (if (= n 4)
+    1
+    (1+ (chain-length (fast-letter-count n)))))
+
+(defun print-chain (n)
+  (let ((lc (letter-count n)))
+    (format t "~D - ~R -> ~D~%" n n lc)
+    (when (not (= n 4))
+      (print-chain lc))))
+
+
+(define-constant +cache-size+ 1000)
+(define-constant +cache+
+  (make-array +cache-size+
+    :element-type 'fixnum
+    :initial-contents (iterate (for i :from 0 :below +cache-size+)
+                               (collect (chain-length i)))))
+
+(defun chain-length% (n)
+  (iterate
+    (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)))))))
+
+
+(defun longest-chain (max)
+  (iterate
+    (for i :from 1 :to max)
+    (finding i :maximizing (chain-length% i))))
+
+
+
+; (time
+;   (print-chain (longest-chain (expt 10 9))))
diff -r 5c8d604c6f01 -r d2c07bcc6144 src/profiling.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/profiling.lisp	Thu Sep 15 14:23:13 2016 +0000
@@ -0,0 +1,34 @@
+(in-package #:sand.profiling)
+
+#+sbcl
+(defun dump-profile ()
+  (with-open-file (*standard-output* "sand.prof"
+                                     :direction :output
+                                     :if-exists :supersede)
+    (sb-sprof:report :type :graph
+                     :sort-by :cumulative-samples
+                     :sort-order :ascending)
+    (sb-sprof:report :type :flat
+                     :min-percent 0.5)))
+
+#+sbcl
+(defun start-profiling ()
+  (sb-sprof::reset)
+  ; (sb-sprof::profile-call-counts "SILT")
+  (sb-sprof::start-profiling :max-samples 50000
+                             :mode :cpu
+                             ; :mode :time
+                             :sample-interval 0.01
+                             :threads :all))
+
+#+sbcl
+(defun stop-profiling ()
+  (sb-sprof::stop-profiling)
+  (dump-profile))
+
+
+(defmacro profile (&body body)
+  `(prog2
+    (start-profiling)
+    (progn ,@body)
+    (stop-profiling)))
diff -r 5c8d604c6f01 -r d2c07bcc6144 src/sketch.lisp
--- a/src/sketch.lisp	Thu Sep 15 14:22:08 2016 +0000
+++ b/src/sketch.lisp	Thu Sep 15 14:23:13 2016 +0000
@@ -1,7 +1,7 @@
 (in-package #:sand.sketch)
 
 ;;;; Config
-(setf *bypass-cache* t)
+; (setf *bypass-cache* t)
 (defparameter *wat* nil)
 (defparameter *width* 600)
 (defparameter *height* 600)