# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1521861247 14400
# Node ID d5b02d8c4803cfc04010814366e9f155e4b69327
# Parent  2c3734fe6cd178624f24c252f61a2a08b252fd6d
Add stippling, tests

diff -r 2c3734fe6cd1 -r d5b02d8c4803 .ffignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.ffignore	Fri Mar 23 23:14:07 2018 -0400
@@ -0,0 +1,3 @@
+syntax:glob
+*.png
+*.svg
diff -r 2c3734fe6cd1 -r d5b02d8c4803 Makefile
--- a/Makefile	Fri Mar 23 19:28:05 2018 -0400
+++ b/Makefile	Fri Mar 23 23:14:07 2018 -0400
@@ -1,7 +1,11 @@
-.PHONY: vendor
+.PHONY: vendor test
 
 # Vendor ----------------------------------------------------------------------
 vendor/quickutils.lisp: vendor/make-quickutils.lisp
 	cd vendor && sbcl --noinform --load make-quickutils.lisp  --eval '(quit)'
 
 vendor: vendor/quickutils.lisp
+
+# Test ------------------------------------------------------------------------
+test:
+	sbcl --noinform --load test/test.lisp --eval '(quit)'
diff -r 2c3734fe6cd1 -r d5b02d8c4803 flax.asd
--- a/flax.asd	Fri Mar 23 19:28:05 2018 -0400
+++ b/flax.asd	Fri Mar 23 23:14:07 2018 -0400
@@ -10,6 +10,7 @@
                :cl-pcg
                :cl-svg
                :cl-vectors
+               :chancery
                :iterate
                :losh
                :zpng
@@ -41,5 +42,6 @@
        (:file "003-basic-l-systems")
        (:file "004-turtle-curves")
        (:file "005-simple-triangulations")
-       (:file "006-tracing-lines")))))))
+       (:file "006-tracing-lines")
+       (:file "007-stippling")))))))
 
diff -r 2c3734fe6cd1 -r d5b02d8c4803 package.lisp
--- a/package.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/package.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -11,7 +11,9 @@
   (:use :cl :iterate :losh :flax.base :flax.quickutils)
   (:export
     :coord :x :y
+    :radial
     :distance
+    :coord+
     :clerp
     :coord-to-cons))
 
@@ -35,6 +37,7 @@
     :path
     :points
     :rectangle
+    :point
     :circle
     :text))
 
@@ -72,6 +75,12 @@
   (:use :cl :iterate :losh :flax.base :flax.quickutils
     :flax.colors
     :flax.coordinates)
+ (:export :loom))
+
+(defpackage :flax.looms.007-stipple
+  (:use :cl :iterate :losh :flax.base :flax.quickutils
+    :flax.colors
+    :flax.coordinates)
   (:export :loom))
 
 
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/base.lisp
--- a/src/base.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/base.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -7,7 +7,8 @@
 (defmacro with-seed (seed &body body)
   (once-only (seed)
     `(let ((pcg::*global-generator*
-             (pcg:make-pcg :seed (pr (or ,seed (random (expt 2 31)))))))
+             (pcg:make-pcg :seed (pr (or ,seed (random (expt 2 31))))))
+           (chancery:*random* #'rand))
        (losh::clear-gaussian-spare)
        ,@body)))
 
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/coordinates.lisp
--- a/src/coordinates.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/coordinates.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -9,13 +9,21 @@
   (make-coord (coerce x 'single-float)
               (coerce y 'single-float)))
 
+(defun radial (angle magnitude)
+  (coord (* magnitude (cos angle))
+         (* magnitude (sin angle))))
+
 (defun distance (c1 c2)
-  (+ (square (- (x c2) (x c1)))
-     (square (- (y c2) (y c1)))))
+  (sqrt (+ (square (- (x c2) (x c1)))
+           (square (- (y c2) (y c1))))))
 
 (defun clerp (from to n)
   (coord (lerp (x from) (x to) n)
          (lerp (y from) (y to) n)))
 
+(defun coord+ (a b)
+  (coord (+ (x a) (x b))
+         (+ (y a) (y b))))
+
 (defun coord-to-cons (c)
   (cons (x c) (y c)))
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/drawing/api.lisp
--- a/src/drawing/api.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/drawing/api.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -148,6 +148,22 @@
             (radius o))))
 
 
+;;;; Points -------------------------------------------------------------------
+(defclass* (point :conc-name "") (drawable)
+  ((location :type coord)))
+
+(defun point (location &key (opacity 1.0d0) (color *black*))
+  (make-instance 'point :location location
+    :color color
+    :opacity (coerce opacity 'double-float)))
+
+(defmethod print-object ((o point) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "(~D, ~D)"
+            (x (location o))
+            (y (location o)))))
+
+
 ;;;; Text ---------------------------------------------------------------------
 (defclass* (text :conc-name "") (drawable)
   ((pos :type coord)
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/drawing/plot.lisp
--- a/src/drawing/plot.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/drawing/plot.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -16,3 +16,15 @@
 
 (defmethod file-extension ((type (eql :plot)))
   "svg")
+
+
+(defmethod draw ((canvas plot-canvas) (p point))
+  (svg:draw (scene canvas)
+            (:path :d (make-svg-path-data canvas (list (location p)
+                                                       (location p)))
+             :stroke-linecap "round"
+             :fill "none"
+             :stroke (web-color (color p))
+             :stroke-width 1
+             :stroke-opacity (opacity p))))
+
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/drawing/png.lisp
--- a/src/drawing/png.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/drawing/png.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -72,6 +72,14 @@
       (vectors:update-state (state canvas) <>))))
 
 
+;;;; Points -------------------------------------------------------------------
+(defmethod draw ((canvas png-canvas) (p point))
+  (with-coordinates canvas
+      ((x y (location p)))
+    (-<> (paths:make-circle-path x y 2)
+      (vectors:update-state (state canvas) <>))))
+
+
 ;;;; Paths --------------------------------------------------------------------
 (defmethod draw ((canvas png-canvas) (p path))
   (-<> (points p)
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/drawing/svg.lisp
--- a/src/drawing/svg.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/drawing/svg.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -50,6 +50,14 @@
                               :fill (web-color (color circ))
                               :fill-opacity (opacity circ)))))
 
+;;;; Points -------------------------------------------------------------------
+(defmethod draw ((canvas svg-canvas) (p point))
+  (with-coordinates canvas
+      ((x y (location p)))
+    (svg:draw (scene canvas) (:circle :cx x :cy y :r 2.0
+                              :fill (web-color (color p))
+                              :fill-opacity (opacity p)))))
+
 
 ;;;; Text ---------------------------------------------------------------------
 (defmethod draw ((canvas svg-canvas) (text text))
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/looms/002-wobbly-lines.lisp
--- a/src/looms/002-wobbly-lines.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/looms/002-wobbly-lines.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -55,7 +55,7 @@
 
 
 ;;;; Main ---------------------------------------------------------------------
-(defun loom (seed filename filetype width height &key mode ticks)
+(defun loom (seed filename filetype width height &key mode ticks verbose)
   (nest
     (with-seed seed)
     (flax.drawing:with-rendering (canvas filetype filename width height
@@ -69,7 +69,8 @@
           (*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))
+        (when (and verbose
+                   (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))
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/looms/003-basic-l-systems.lisp
--- a/src/looms/003-basic-l-systems.lisp	Fri Mar 23 19:28:05 2018 -0400
+++ b/src/looms/003-basic-l-systems.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -96,7 +96,7 @@
 (defun random-anabaena-catenula-axiom (length)
   (gimme length (random-elt '(ar al br bl) #'rand)))
 
-(defun loom-anabaena-catenula (seed filename filetype width height)
+(defun loom (seed filename filetype width height)
   (nest
     (with-seed seed)
     (flax.drawing:with-rendering
@@ -108,4 +108,6 @@
                        :callback (lambda (iteration word)
                                    (flax.drawing:render canvas (convert word iteration))))))
 
+
+
 ;; (time (loom-anabaena-catenula nil "out" :svg 800 800))
diff -r 2c3734fe6cd1 -r d5b02d8c4803 src/looms/007-stippling.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/looms/007-stippling.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -0,0 +1,129 @@
+(in-package :flax.looms.007-stipple)
+
+
+;;;; Convert ------------------------------------------------------------------
+(defun convert (points)
+  (mapcar #'flax.drawing:point points))
+
+
+;;;; Shapes -------------------------------------------------------------------
+(defstruct (rectangle (:conc-name nil)) a b)
+(defstruct (circle (:conc-name nil)) center radius)
+
+
+(define-with-macro (rectangle :conc-name "") a b)
+(define-with-macro (circle :conc-name "") center radius)
+
+
+(defun random-coord ()
+  (coord (rand 1.0) (rand 1.0)))
+
+(defun gen-rectangle ()
+  (make-rectangle :a (random-coord) :b (random-coord)))
+
+(defun gen-circle ()
+  (make-circle :center (random-coord)
+               :radius (random-range 0.01 0.2 #'rand)))
+
+(chancery:define-rule (gen-shape :distribution :weighted)
+  (1 gen-rectangle)
+  (1 gen-circle))
+
+(defun gen (shapes)
+  (gimme shapes (gen-shape)))
+
+
+
+;;;; Bounds -------------------------------------------------------------------
+(defgeneric bounding-box (shape))
+
+(defmethod bounding-box ((shape rectangle))
+  (cons (a shape) (b shape)))
+
+(defmethod bounding-box ((shape circle))
+  (with-circle (shape c r)
+    (let ((x (x c))
+          (y (y c)))
+      (cons (coord (- x r) (- y r))
+            (coord (+ x r) (+ y r))))))
+
+(defun random-point-in-bounding-box (bounding-box)
+  (destructuring-bind (a . b) bounding-box
+    (let ((x1 (min (x a) (x b)))
+          (x2 (max (x a) (x b)))
+          (y1 (min (y a) (y b)))
+          (y2 (max (y a) (y b))))
+      (coord (random-range-inclusive x1 x2 #'rand)
+             (random-range-inclusive y1 y2 #'rand)))))
+
+
+;;;; Area ---------------------------------------------------------------------
+(defgeneric area (shape))
+
+(defmethod area ((shape rectangle))
+  (with-rectangle (shape)
+    (* (abs (- (x a) (x b)))
+       (abs (- (y a) (y b))))))
+
+(defmethod area ((shape circle))
+  (* 1/2tau (square (radius shape))))
+
+
+;;;; Containment --------------------------------------------------------------
+(defgeneric containsp (shape point)
+  (:documentation
+    "Return whether `shape` contains `point`.
+
+  `point` is assumed to lie somewhere inside `shape`'s bounding box.
+
+  "))
+
+(defmethod containsp ((shape rectangle) point)
+  t)
+
+(defmethod containsp ((shape circle) point)
+  (<= (distance point (center shape))
+      (radius shape)))
+
+(defun canvas-contains-p (point)
+  (and (<= 0 (x point) 1)
+       (<= 0 (y point) 1)))
+
+(defun random-point-in-shape (shape)
+  (iterate
+    (with bb = (bounding-box shape))
+    (for p = (random-point-in-bounding-box bb))
+    (finding p :such-that (and (canvas-contains-p p)
+                               (containsp shape p)))))
+
+
+;;;; Stipple ------------------------------------------------------------------
+(defun perturb-ratio (ratio)
+  (* ratio (clamp 0 10 (random-gaussian 1.0 20/100 #'rand))))
+
+(defun stipple-shape (shape ratio)
+  (gimme (round (* (perturb-ratio ratio)
+                   (area shape)))
+         (random-point-in-shape shape)))
+
+(defun stipple (shapes ratio)
+  (mapcan (rcurry #'stipple-shape ratio) shapes))
+
+
+;;;; Main ---------------------------------------------------------------------
+(defun loom (seed filename filetype width height &key shapes ratio)
+  (nest
+    (with-seed seed)
+    (flax.drawing:with-rendering (canvas filetype filename width height
+                                         :background (hsv 0.09 0.05 0.975)))
+    (randomly-initialize
+      ((shapes (clamp 1 100 (random-gaussian-integer 6 2 #'rand)))))
+    (progn
+      (-<> (gen shapes)
+        (stipple <> (/ (or ratio 100000) shapes))
+        convert
+        (flax.drawing:render canvas <>))
+      (values shapes))))
+
+;; (time (loom 11 "out" :png 800 800))
+(time (loom 112 "out" :plot 800 800 :ratio 40000))
diff -r 2c3734fe6cd1 -r d5b02d8c4803 test/test.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/test.lisp	Fri Mar 23 23:14:07 2018 -0400
@@ -0,0 +1,16 @@
+(ql:quickload '(:flax :losh))
+
+(defun check (loom)
+  (terpri)
+  (losh:pr 'checking loom)
+  (funcall loom nil "out" (losh:random-elt '(:png :svg :plot)) 500 500)
+  (losh:pr 'ok))
+
+(progn
+  (check #'flax.looms.001-triangles:loom)
+  (check #'flax.looms.002-wobbly-lines:loom)
+  (check #'flax.looms.003-basic-l-systems:loom)
+  (check #'flax.looms.004-turtle-curves:loom)
+  (check #'flax.looms.005-simple-triangulations:loom)
+  (check #'flax.looms.006-tracing-lines:loom)
+  (check #'flax.looms.007-stipple:loom))