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