# HG changeset patch # User Steve Losh # Date 1481845990 18000 # Node ID de58fc1af1e59794039f4e33f2987317fb100cdc # Parent c6cecc512cbc507dce366a5898276cdb5089f39b Poke a bit more at TNTO diff -r c6cecc512cbc -r de58fc1af1e5 package.lisp --- a/package.lisp Thu Dec 15 16:35:22 2016 -0500 +++ b/package.lisp Thu Dec 15 18:53:10 2016 -0500 @@ -98,20 +98,6 @@ :degrees :radians)) -(defpackage :sand.wallpaper - (:use - :cl - :losh - :sketch - :iterate - :sand.quickutils - :sand.utils) - (:shadowing-import-from :iterate - :in) - (:shadowing-import-from :sketch - :degrees - :radians)) - (defpackage :sand.markov (:use :cl @@ -294,3 +280,24 @@ )) +(defpackage :sand.turing-omnibus.wallpaper + (:use + :cl + :losh + :sketch + :iterate + :sand.quickutils + :sand.utils) + (:shadowing-import-from :iterate + :in) + (:shadowing-import-from :sketch + :degrees + :radians)) + +(defpackage :sand.turing-omnibus.monto-carlo + (:use + :cl + :losh + :iterate + :sand.quickutils + :sand.utils)) diff -r c6cecc512cbc -r de58fc1af1e5 sand.asd --- a/sand.asd Thu Dec 15 16:35:22 2016 -0500 +++ b/sand.asd Thu Dec 15 18:53:10 2016 -0500 @@ -23,13 +23,13 @@ :html-entities :iterate :losh - :trivia :parenscript :plump :rs-colors :sanitize :sketch :split-sequence + :trivia :yason ) @@ -70,4 +70,7 @@ :serial t :components ((:file "compiler"))) (:file "sketch") - (:file "wallpaper"))))) + (:module "turing-omnibus" + :serial t + :components ((:file "wallpaper") + (:file "monte-carlo"))))))) diff -r c6cecc512cbc -r de58fc1af1e5 src/turing-omnibus/monte-carlo.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/turing-omnibus/monte-carlo.lisp Thu Dec 15 18:53:10 2016 -0500 @@ -0,0 +1,27 @@ +(in-package :sand.turing-omnibus.monto-carlo) + +;;;; From The New Turing Omnibus, Chapter 4 + +(defun frequency (alpha time) + (* (/ alpha) + (exp (- (/ time alpha))))) + +(defun cumulative-frequency (alpha time) + (- 1 (exp (- (/ time alpha))))) + +(defun inverse-cumulative-frequency (alpha x) + (* alpha (log (- 1 x)))) + +;; Something is fucky with the above inverse function given by the book... `α +;; ln(1 - x)` will always give a negative result (for x in [0, 1)), so how can +;; we use it as a number of seconds to wait? + +; (defun simulate (1000) +; (let ((max-time ))) +; ) + +; (gnuplot-function (curry #'inverse-cumulative-frequency 1.0) +; :start 0.0 +; :end 1.00 +; :step 0.1) + diff -r c6cecc512cbc -r de58fc1af1e5 src/turing-omnibus/wallpaper.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/turing-omnibus/wallpaper.lisp Thu Dec 15 18:53:10 2016 -0500 @@ -0,0 +1,110 @@ +(in-package :sand.turing-omnibus.wallpaper) + +;;;; From The New Turing Omnibus, Chapter 1 + +;;;; Config +(defparameter *width* 600) +(defparameter *height* 600) + + +;;;; Utils +(defmacro with-setup (&body body) + `(progn + (background (gray 1.0)) + ,@body)) + +(defmacro in-context (&body body) + `(prog1 + (push-matrix) + (progn ,@body) + (pop-matrix))) + +(defmacro scancode-case (scancode-form &rest pairs) + (with-gensyms (scancode) + `(let ((,scancode ,scancode-form)) + (cond + ,@(mapcar (lambda (pair) + (destructuring-bind (key-scancode &rest body) pair + `((sdl2:scancode= ,scancode ,key-scancode) + ,@body))) + pairs))))) + +(defmacro just-once (dirty-place &body body) + `(when ,dirty-place + (setf ,dirty-place nil) + ,@body)) + + +;;;; Sketch +(defun plot (x y color) + (with-pen (make-pen :fill color) + (in-context + (translate x y) + (rect 0 0 1 1)))) + +(defsketch wallpaper + ((width *width*) (height *height*) (y-axis :up) (title "Wallpaper") + (copy-pixels t) + (mouse (list 0 0)) + (mouse-down-left nil) + (mouse-down-right nil) + (dirty t) + ;; Data + (palette (iterate (repeat (random-range 2 10)) + (collect (rgb (random 1.0) (random 1.0) (random 1.0)) + :result-type 'vector))) + (corner-a (random 100)) + (corner-b (random 100)) + (side (random-range 10.0 20.0)) + (tiles (random-range 40 110)) + (number-of-colors (length palette))) + ;; + (just-once dirty + (with-setup + (in-context + (scale (/ *width* tiles)) + (iterate + (for-nested ((i :from 0 :below tiles) + (j :from 0 :below tiles))) + (for x = (+ corner-a (* i (/ side tiles)))) + (for y = (+ corner-b (* j (/ side tiles)))) + (for c = (truncate (+ (* x x) (* y y)))) + (plot i j (aref palette (mod c number-of-colors))))) + (with-pen (make-pen :fill (rgb 1.0 1.0 1.0)) + (rect 0 0 110 20)) + (text (format nil "Side: ~8F" side) 0 0))) + ;; + + ) + + +;;;; Keyboard +(defun keydown (instance scancode) + (declare (ignorable instance)) + (scancode-case scancode + (:scancode-space (sketch::prepare instance)) + (:scancode-up (mulf (slot-value instance 'side) 1.01)) + (:scancode-down (mulf (slot-value instance 'side) 0.99)) + (:scancode-l (decf (slot-value instance 'corner-a))) + (:scancode-h (incf (slot-value instance 'corner-a))) + (:scancode-k (decf (slot-value instance 'corner-b))) + (:scancode-j (incf (slot-value instance 'corner-b))) + ) + (setf (slot-value instance 'dirty) t)) + +(defun keyup (instance scancode) + (declare (ignorable instance)) + (scancode-case scancode + (:scancode-space nil))) + + +(defmethod kit.sdl2:keyboard-event ((instance wallpaper) state timestamp repeatp keysym) + (declare (ignore timestamp repeatp)) + (cond + ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym))) + ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym))) + (t nil))) + + +;;;; Run +; (defparameter *wallpaper* (make-instance 'wallpaper)) diff -r c6cecc512cbc -r de58fc1af1e5 src/wallpaper.lisp --- a/src/wallpaper.lisp Thu Dec 15 16:35:22 2016 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -(in-package :sand.wallpaper) - -;;;; From The New Turing Omnibus, Chapter 1 - -;;;; Config -(defparameter *width* 600) -(defparameter *height* 600) - - -;;;; Utils -(defmacro with-setup (&body body) - `(progn - (background (gray 1.0)) - ,@body)) - -(defmacro in-context (&body body) - `(prog1 - (push-matrix) - (progn ,@body) - (pop-matrix))) - -(defmacro scancode-case (scancode-form &rest pairs) - (with-gensyms (scancode) - `(let ((,scancode ,scancode-form)) - (cond - ,@(mapcar (lambda (pair) - (destructuring-bind (key-scancode &rest body) pair - `((sdl2:scancode= ,scancode ,key-scancode) - ,@body))) - pairs))))) - -(defmacro just-once (dirty-place &body body) - `(when ,dirty-place - (setf ,dirty-place nil) - ,@body)) - - -;;;; Sketch -(defun plot (x y color) - (with-pen (make-pen :fill color) - (in-context - (translate x y) - (rect 0 0 1 1)))) - -(defsketch wallpaper - ((width *width*) (height *height*) (y-axis :up) (title "Wallpaper") - (copy-pixels t) - (mouse (list 0 0)) - (mouse-down-left nil) - (mouse-down-right nil) - (dirty t) - ;; Data - (palette (iterate (repeat (random-range 2 10)) - (collect (rgb (random 1.0) (random 1.0) (random 1.0)) - :result-type 'vector))) - (corner-a (random 100)) - (corner-b (random 100)) - (side (random-range 10.0 20.0)) - (tiles (random-range 40 110)) - (number-of-colors (length palette))) - ;; - (just-once dirty - (with-setup - (in-context - (scale (/ *width* tiles)) - (iterate - (for-nested ((i :from 0 :below tiles) - (j :from 0 :below tiles))) - (for x = (+ corner-a (* i (/ side tiles)))) - (for y = (+ corner-b (* j (/ side tiles)))) - (for c = (truncate (+ (* x x) (* y y)))) - (plot i j (aref palette (mod c number-of-colors))))) - (with-pen (make-pen :fill (rgb 1.0 1.0 1.0)) - (rect 0 0 110 20)) - (text (format nil "Side: ~8F" side) 0 0))) - ;; - - ) - - -;;;; Keyboard -(defun keydown (instance scancode) - (declare (ignorable instance)) - (scancode-case scancode - (:scancode-space (sketch::prepare instance)) - (:scancode-up (mulf (slot-value instance 'side) 1.01)) - (:scancode-down (mulf (slot-value instance 'side) 0.99)) - (:scancode-l (decf (slot-value instance 'corner-a))) - (:scancode-h (incf (slot-value instance 'corner-a))) - (:scancode-k (decf (slot-value instance 'corner-b))) - (:scancode-j (incf (slot-value instance 'corner-b))) - ) - (setf (slot-value instance 'dirty) t)) - -(defun keyup (instance scancode) - (declare (ignorable instance)) - (scancode-case scancode - (:scancode-space nil))) - - -(defmethod kit.sdl2:keyboard-event ((instance wallpaper) state timestamp repeatp keysym) - (declare (ignore timestamp repeatp)) - (cond - ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym))) - ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym))) - (t nil))) - - -;;;; Run -; (defparameter *wallpaper* (make-instance 'wallpaper)) diff -r c6cecc512cbc -r de58fc1af1e5 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Thu Dec 15 16:35:22 2016 -0500 +++ b/vendor/make-quickutils.lisp Thu Dec 15 18:53:10 2016 -0500 @@ -13,8 +13,10 @@ :hash-table-keys :hash-table-plist :hash-table-values + :iota :n-grams :once-only + :range :rcurry :read-file-into-string :required-argument diff -r c6cecc512cbc -r de58fc1af1e5 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Thu Dec 15 16:35:22 2016 -0500 +++ b/vendor/quickutils.lisp Thu Dec 15 18:53:10 2016 -0500 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :ENSURE-LIST :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "SAND.QUICKUTILS") @@ -19,8 +19,9 @@ :HASH-TABLE-ALIST :MAPHASH-KEYS :HASH-TABLE-KEYS :HASH-TABLE-PLIST :MAPHASH-VALUES :HASH-TABLE-VALUES - :TAKE :N-GRAMS :ONCE-ONLY :RCURRY - :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE + :IOTA :TAKE :N-GRAMS :ONCE-ONLY :RANGE + :RCURRY :WITH-OPEN-FILE* + :WITH-INPUT-FROM-FILE :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SUBDIVIDE :MKSTR :SYMB :TREE-COLLECT @@ -208,6 +209,24 @@ values)) + (declaim (inline iota)) + (defun iota (n &key (start 0) (step 1)) + "Return a list of `n` numbers, starting from `start` (with numeric contagion +from `step` applied), each consequtive number being the sum of the previous one +and `step`. `start` defaults to `0` and `step` to `1`. + +Examples: + + (iota 4) => (0 1 2 3) + (iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0) + (iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)" + (declare (type (integer 0) n) (number start step)) + (loop repeat n + ;; KLUDGE: get numeric contagion right for the first element too + for i = (+ (- (+ start step) step)) then (+ i step) + collect i)) + + (defun take (n sequence) "Take the first `n` elements from `sequence`." (subseq sequence 0 n)) @@ -268,6 +287,14 @@ ,@forms))))) + (defun range (start end &key (step 1) (key 'identity)) + "Return the list of numbers `n` such that `start <= n < end` and +`n = start + k*step` for suitable integers `k`. If a function `key` is +provided, then apply it to each number." + (assert (<= start end)) + (loop :for i :from start :below end :by step :collecting (funcall key i))) + + (defun rcurry (function &rest arguments) "Returns a function that applies the arguments it is called with and `arguments` to `function`." @@ -449,7 +476,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (export '(compose curry define-constant ensure-gethash ensure-list hash-table-alist hash-table-keys hash-table-plist hash-table-values - n-grams once-only rcurry read-file-into-string required-argument - riffle subdivide symb tree-collect with-gensyms with-unique-names))) + iota n-grams once-only range rcurry read-file-into-string + required-argument riffle subdivide symb tree-collect with-gensyms + with-unique-names))) ;;;; END OF quickutils.lisp ;;;;