--- 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)
--- 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`.
--- 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.
--- 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))
--- 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))
--- 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))
--- 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)
;; ))
--- 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 ))
--- 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))