# HG changeset patch # User Steve Losh # Date 1521847108 14400 # Node ID b098ec32e059a840818cb01b63a47a5cf3702822 # Parent 2291dea58ea9ec44a7849ef5e73d535fabdb0bb7 Clean shit up diff -r 2291dea58ea9 -r b098ec32e059 package.lisp --- a/package.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/package.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -1,6 +1,11 @@ (defpackage :flax.base (:use :cl :iterate :losh :flax.quickutils) - (:export :rand :with-seed :round-to)) + (:export + :rand + :with-seed + :random-or + :randomly-initialize + :round-to)) (defpackage :flax.coordinates (:use :cl :iterate :losh :flax.base :flax.quickutils) diff -r 2291dea58ea9 -r b098ec32e059 src/base.lisp --- a/src/base.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/base.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -1,14 +1,27 @@ (in-package :flax.base) +;;;; Randomness --------------------------------------------------------- (defun rand (bound) (pcg:pcg-random t bound)) (defmacro with-seed (seed &body body) - `(let ((pcg::*global-generator* (pcg:make-pcg :seed ,seed))) - (losh::clear-gaussian-spare) + (once-only (seed) + `(let ((pcg::*global-generator* + (pcg:make-pcg :seed (pr (or ,seed (random (expt 2 31))))))) + (losh::clear-gaussian-spare) + ,@body))) + +(defmacro random-or (value random-form) + (once-only (value random-form) + `(or ,value ,random-form))) + +(defmacro randomly-initialize (bindings &body body) + `(let ,(iterate (for (symbol init-form) :in bindings) + (collect `(,symbol (random-or ,symbol ,init-form)))) ,@body)) +;;;; Math --------------------------------------------------------- (defun round-to (number precision) "Round `number` to the given `precision`. diff -r 2291dea58ea9 -r b098ec32e059 src/drawing/api.lisp --- a/src/drawing/api.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/drawing/api.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -200,7 +200,7 @@ :width ,width :background ,background)) (*padding* ,padding)) - (prog1 ,@body + (multiple-value-prog1 ,@body (write-file ,canvas-symbol (full-filename ,filename ,canvas-type))))))) @@ -212,5 +212,5 @@ ;;; * Add a new subclass of canvas. ;;; * Implement make-canvas. ;;; * Implement all the drawing methods for the various shapes. -;;; * Implement render (which should call draw and maybe do other stuff). +;;; * Implement render-object (which should call draw and maybe do other stuff). ;;; * Implement write-file. diff -r 2291dea58ea9 -r b098ec32e059 src/looms/001-triangles.lisp --- a/src/looms/001-triangles.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/looms/001-triangles.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -76,29 +76,34 @@ (list (triangle p b a) (triangle p a c))))) -(defun generate-universe-balancing (depth seed) - (losh::clear-gaussian-spare) - (with-seed seed - (gathering - (labels ((should-stop-p (iteration) - (or (= depth iteration) - (and (> iteration 6) - (randomp (map-range 0 depth - 0.0 0.05 - iteration) - #'rand)))) - (recur (triangle &optional (iteration 0)) - (if (should-stop-p iteration) - (gather triangle) - (map nil (rcurry #'recur (1+ iteration)) - (split-triangle-self-balancing triangle))))) - (map nil #'recur (initial-triangles)))))) +(defun generate-universe-balancing (depth) + (gathering + (labels ((should-stop-p (iteration) + (or (= depth iteration) + (and (> iteration 6) + (randomp (map-range 0 depth + 0.0 0.05 + iteration) + #'rand)))) + (recur (triangle &optional (iteration 0)) + (if (should-stop-p iteration) + (gather triangle) + (map nil (rcurry #'recur (1+ iteration)) + (split-triangle-self-balancing triangle))))) + (map nil #'recur (initial-triangles))))) ;;;; Main --------------------------------------------------------------------- -(defun loom (seed depth filename filetype width height) - (flax.drawing:with-rendering (canvas filetype filename width height) - (flax.drawing:render canvas (convert (generate-universe-balancing depth seed))))) +(defun loom (seed filename filetype width height &key depth) + (nest + (with-seed seed) + (randomly-initialize ((depth (random-range-inclusive 14 19 #'rand)))) + (flax.drawing:with-rendering (canvas filetype filename width height)) + (progn + (-<> (generate-universe-balancing depth) + convert + (flax.drawing:render canvas <>)) + (values depth)))) -;; (time (loom (pr (random (expt 2 31))) 12 "out" :svg 1000 1000)) +;; (time (loom nil "out" :svg 800 800)) diff -r 2291dea58ea9 -r b098ec32e059 src/looms/002-wobbly-lines.lisp --- a/src/looms/002-wobbly-lines.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/looms/002-wobbly-lines.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -55,25 +55,29 @@ ;;;; Main --------------------------------------------------------------------- -(defun loom (seed ticks filename filetype width height) - (with-seed seed +(defun loom (seed filename filetype width height &key mode ticks) + (nest + (with-seed seed) (flax.drawing:with-rendering (canvas filetype filename width height :padding 0.0 - :background *background*) - (let ((line (initial 300)) - (*hue* (random-range 0.0d0 1.0d0 #'rand)) - (*hue-increment* (/ (random-range 0.15d0 0.3d0 #'rand) ticks)) - (mode (random-elt '(:opaque :transparent :fade) #'rand))) - (dotimes (tick ticks) - (when (dividesp tick (/ (expt 10 (floor (log (1- ticks) 10))) 2)) - (print tick)) - (when (and (eq filetype :png) (eq mode :fade) (dividesp tick 10)) - (flax.drawing:fade canvas *background* 0.04d0)) - (flax.drawing:render canvas (convert line (if (eq mode :transparent) - (/ 95.0d0 ticks) - 1.0d0))) - (tick line)) - mode)))) + :background *background*)) + (randomly-initialize + ((ticks (round-to (random-range 800 5000 #'rand) 100)) + (mode (random-elt '(:opaque :transparent :fade) #'rand)))) + (let ((line (initial 300)) + (*hue* (random-range 0.0d0 1.0d0 #'rand)) + (*hue-increment* (/ (random-range 0.15d0 0.3d0 #'rand) ticks)))) + (progn + (dotimes (tick ticks) + (when (dividesp tick (/ (expt 10 (floor (log (1- ticks) 10))) 2)) + (print tick)) + (when (and (eq filetype :png) (eq mode :fade) (dividesp tick 10)) + (flax.drawing:fade canvas *background* 0.04d0)) + (flax.drawing:render canvas (convert line (if (eq mode :transparent) + (/ 95.0d0 ticks) + 1.0d0))) + (tick line)) + (values mode ticks)))) -;; (time (loom nil 1000 "out" :svg 800 300)) +;; (time (loom 133 "out" :svg 800 300)) diff -r 2291dea58ea9 -r b098ec32e059 src/looms/003-basic-l-systems.lisp --- a/src/looms/003-basic-l-systems.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/looms/003-basic-l-systems.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -97,14 +97,15 @@ (gimme length (random-elt '(ar al br bl) #'rand))) (defun loom-anabaena-catenula (seed filename filetype width height) - (with-seed seed + (nest + (with-seed seed) (flax.drawing:with-rendering - (canvas filetype filename width height :background *background*) - (anabaena-catenula (maximum-words) - :axiom (random-anabaena-catenula-axiom - (random-range-inclusive 1 6 #'rand)) - :mutate #'cull - :callback (lambda (iteration word) - (flax.drawing:render canvas (convert word iteration))))))) + (canvas filetype filename width height :background *background*)) + (anabaena-catenula (maximum-words) + :axiom (random-anabaena-catenula-axiom + (random-range-inclusive 1 6 #'rand)) + :mutate #'cull + :callback (lambda (iteration word) + (flax.drawing:render canvas (convert word iteration)))))) -;; (time (loom-anabaena-catenula nil "out" :png 2000 2000)) +;; (time (loom-anabaena-catenula nil "out" :svg 800 800)) diff -r 2291dea58ea9 -r b098ec32e059 src/looms/004-turtle-curves.lisp --- a/src/looms/004-turtle-curves.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/looms/004-turtle-curves.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -83,22 +83,21 @@ (minimizing (y p2) :into min-y) (finally (return (list min-x min-y max-x max-y))))) -(defun scale (paths &optional (bottom-padding 0)) +(defun scale (paths) (iterate ;; (with aspect = 1) (with (min-x min-y max-x max-y) = (find-bounds paths)) (with factor = (min (/ (- max-x min-x)) (/ (- max-y min-y)))) - (with x-padding = (+ (/ (- 1.0 (* factor (- max-x min-x))) 2) - (/ bottom-padding 2))) + (with x-padding = (/ (- 1.0 (* factor (- max-x min-x))) 2)) (with y-padding = (/ (- 1.0 (* factor (- max-y min-y))) 2)) (for path :in paths) (for (p1 p2) = (flax.drawing:points path)) (zapf (x p1) (map-range min-x max-x x-padding (- 1.0 x-padding) %) - (y p1) (map-range min-y max-y y-padding (- 1.0 y-padding bottom-padding) %) + (y p1) (map-range min-y max-y y-padding (- 1.0 y-padding) %) (x p2) (map-range min-x max-x x-padding (- 1.0 x-padding) %) - (y p2) (map-range min-y max-y y-padding (- 1.0 y-padding bottom-padding) %))) + (y p2) (map-range min-y max-y y-padding (- 1.0 y-padding) %))) paths) @@ -117,19 +116,6 @@ (appending (perform-command turtle command n)))) -;;;; Production Drawing ------------------------------------------------------- -(defun draw-productions (productions size) - (iterate - (with width = (/ 1.0 (/ (length productions) 2))) - (for (word production) :on productions :by #'cddr) - (for x :from (/ width 2) :by width) - (collect (flax.drawing:text - (coord x 1.0) size "Montepetrum" - (string-downcase (format nil "~S ~S" word production)) - :align :middle - :color (rgb 1 1 1))))) - - ;;;; L-Systems ---------------------------------------------------------------- (defun expand (word productions) (mappend (lambda (letter) @@ -260,6 +246,14 @@ (iterate (for (letter production . nil) :on productions :by #'cddr) (appending (list letter (mutate-production (copy-list production)))))) +(defun maybe-mutate-productions (productions) + (let ((should-mutate (randomp 0.6 #'rand)) + (mutation-seed (rand (expt 2 31)))) + (if should-mutate + (with-seed mutation-seed + (values (mutate-productions productions) mutation-seed)) + productions))) + ;;;; Main --------------------------------------------------------------------- (defun select-l-system () @@ -284,55 +278,45 @@ (,*tree-f* 4 7 ,(- 1/4tau))) #'rand)) + (defun loom (seed filename filetype width height - &key l-system iterations starting-angle render-productions) + &key l-system iterations starting-angle) (nest (with-seed seed) (destructuring-bind - (l-system min-iterations max-iterations &optional starting-angle) - (if l-system - (list l-system iterations iterations starting-angle) - (select-l-system))) - (let* ((*starting-angle* (or (or starting-angle (rand tau)))) + (random-l-system min-iterations max-iterations &optional random-starting-angle) + (select-l-system)) + (randomly-initialize + ((starting-angle (random-or random-starting-angle (rand tau))) + (iterations (random-range-inclusive min-iterations max-iterations #'rand)) + (l-system random-l-system))) + (let* ((*starting-angle* starting-angle) (bg (hsv (rand 1.0) (rand 1.0) (random-range 0.0 0.2 #'rand))) (*color* (hsv (rand 1.0) (random-range 0.5 0.8 #'rand) (random-range 0.9 1.0 #'rand))) - (iterations (random-range-inclusive min-iterations - max-iterations - #'rand)) (axiom (l-system-axiom l-system)) - (should-mutate (randomp 0.6 #'rand)) - (mutation-seed (rand (expt 2 31))) - (production-font-size 0.04) - (productions (-<> l-system - l-system-productions - (if should-mutate - (with-seed mutation-seed - (mutate-productions <>)) - <>))) (*angle* (l-system-recommended-angle l-system)))) + (multiple-value-bind (productions mutagen) + (-<> l-system + l-system-productions + maybe-mutate-productions)) (flax.drawing:with-rendering - (canvas filetype filename width height - :background bg - :padding (if render-productions 0.015 0.05))) - (progn (-<> (run-l-system axiom productions iterations) - turtle-draw - (scale <> (if render-productions (* 1.1 production-font-size) 0.0)) - (flax.drawing:render canvas <>)) - (when render-productions - (-<> productions - (draw-productions <> production-font-size) - (flax.drawing:render canvas <>))) - (list (l-system-name l-system) - iterations - (if should-mutate mutation-seed nil))))) + (canvas filetype filename width height :background bg :padding 0.05)) + (progn + (-<> (run-l-system axiom productions iterations) + turtle-draw + scale + (flax.drawing:render canvas <>)) + (values (l-system-name l-system) + iterations + mutagen)))) -;; (time (loom (pr (random (expt 2 31))) "out" :svg 800 800 -;; :l-system *hexagonal-gosper-curve* -;; :iterations 4 -;; :starting-angle (- 1/4tau) -;; :render-productions nil + +;; (time (loom 12 "out" :svg 800 800 +;; ;; :l-system *hexagonal-gosper-curve* +;; ;; :iterations 5 +;; ;; :starting-angle (- 1/4tau) ;; )) diff -r 2291dea58ea9 -r b098ec32e059 src/looms/005-simple-triangulations.lisp --- a/src/looms/005-simple-triangulations.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/looms/005-simple-triangulations.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -44,26 +44,30 @@ (collect (funcall generator) :result-type 'vector))) -(defun loom (seed points filename filetype width height &key ratio) - (losh::clear-gaussian-spare) +(defun select-generator () + (random-elt '((generate-point-uniform "Uniform") + (generate-point-gaussian "Gaussian") + (generate-point-gaussian-vertical "Vertical Gaussian") + (generate-point-gaussian-horizontal "Horizontal Gaussian")) + #'rand)) + +(defun loom (seed filename filetype width height &key ratio points) (nest (with-seed seed) (flax.drawing:with-rendering (canvas filetype filename width height :background (hsv 0.09 0.05 0.975))) - (destructuring-bind (generator generator-name) - (random-elt '((generate-point-uniform "Uniform") - (generate-point-gaussian "Gaussian") - (generate-point-gaussian-vertical "Vertical Gaussian") - (generate-point-gaussian-horizontal "Horizontal Gaussian")) - #'rand)) - (let* ((triangulation-ratio (if (randomp 0.5 #'rand) - 1 - (random-range 0.1 0.3 #'rand))) - (triangulation-ratio (or ratio triangulation-ratio)))) + (destructuring-bind (generator generator-name) (select-generator)) + (randomly-initialize + ((ratio (if (randomp 0.5 #'rand) + 1 + (random-range 0.05 0.2 #'rand))) + (points (round-to (random-range-inclusive 200 700 #'rand) + 10)))) (progn - (flax.drawing:render canvas (convert (generate generator points) - triangulation-ratio)) - (list generator-name triangulation-ratio)))) + (-<> (generate generator points) + (convert <> ratio) + (flax.drawing:render canvas <>)) + (values generator-name points ratio)))) -;; (time (loom 5 400 "out" :svg 800 800 :ratio nil)) +;; (time (loom 55 "out" :svg 800 800 )) diff -r 2291dea58ea9 -r b098ec32e059 src/looms/006-tracing-lines.lisp --- a/src/looms/006-tracing-lines.lisp Mon Mar 19 20:21:27 2018 -0400 +++ b/src/looms/006-tracing-lines.lisp Fri Mar 23 19:18:28 2018 -0400 @@ -57,13 +57,14 @@ (with-seed seed) (flax.drawing:with-rendering (canvas filetype filename width height :background (hsv 0 0 0.05))) - (let* ((points% (round-to (random-range 100 150 #'rand) 10)) - (lines% (round-to (random-range 80 140 #'rand) 10)) - (lines (or lines lines%)) - (points (or points points%)) - (*spread-y* (/ 0.15 lines)))) + (randomly-initialize + ((points (round-to (random-range 100 150 #'rand) 10)) + (lines (round-to (random-range 80 140 #'rand) 10)))) + (let ((*spread-y* (/ 0.15 lines)))) (progn - (flax.drawing:render canvas (convert-lines (generate-lines points lines))) - (list points lines)))) + (-<> (generate-lines points lines) + convert-lines + (flax.drawing:render canvas <>)) + (values lines points)))) -;; (time (loom nil "out" :svg 800 800 :lines 200 :points 100)) +;; (time (loom 4 "out" :svg 800 800))