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