# HG changeset patch # User Steve Losh # Date 1521322594 14400 # Node ID 29137fb2d2082ebacc2b7dd08c742c9241b954f7 # Parent 630bc79afdfdbf3875adf66409d3b6c63c405a9d Add text support for SVGs diff -r 630bc79afdfd -r 29137fb2d208 package.lisp --- a/package.lisp Thu Mar 15 00:28:01 2018 -0400 +++ b/package.lisp Sat Mar 17 17:36:34 2018 -0400 @@ -30,7 +30,8 @@ :path :points :rectangle - :circle)) + :circle + :text)) (defpackage :flax.looms.001-triangles diff -r 630bc79afdfd -r 29137fb2d208 src/drawing/api.lisp --- a/src/drawing/api.lisp Thu Mar 15 00:28:01 2018 -0400 +++ b/src/drawing/api.lisp Sat Mar 17 17:36:34 2018 -0400 @@ -148,6 +148,30 @@ (radius o)))) +;;;; Text --------------------------------------------------------------------- +(defclass* (text :conc-name "") (drawable) + ((pos :type coord) + (font :type string) + (size :type single-float) + (align :type keyword) + (content :type string))) + +(defun text (position size font content + &key (opacity 1.0d0) (color *black*) (align :left)) + (make-instance 'text + :pos position :size size :font font :content content + :align align + :color color + :opacity (coerce opacity 'double-float))) + +(defmethod print-object ((o text) s) + (print-unreadable-object (o s :type t :identity nil) + (format s "~S (~D, ~D)" + (content o) + (x (pos o)) + (y (pos o))))) + + ;;;; Rendering ---------------------------------------------------------------- (defgeneric render-object (canvas object)) diff -r 630bc79afdfd -r 29137fb2d208 src/drawing/svg.lisp --- a/src/drawing/svg.lisp Thu Mar 15 00:28:01 2018 -0400 +++ b/src/drawing/svg.lisp Sat Mar 17 17:36:34 2018 -0400 @@ -51,6 +51,21 @@ :fill-opacity (opacity circ))))) +;;;; Text --------------------------------------------------------------------- +(defmethod draw ((canvas svg-canvas) (text text)) + (with-coordinates canvas + ((x y (pos text)) + (size (size text))) + (svg:text (scene canvas) + (:x x :y y + :font-size size + :font-family (font text) + :text-anchor (string-downcase (align text)) ; dammit inkscape + :fill (web-color (color text)) + :fill-opacity (opacity text)) + (content text)))) + + ;;;; Paths -------------------------------------------------------------------- (defun make-svg-path-data (canvas points) (destructuring-bind (first-point &rest remaining-points) diff -r 630bc79afdfd -r 29137fb2d208 src/looms/004-turtle-curves.lisp --- a/src/looms/004-turtle-curves.lisp Thu Mar 15 00:28:01 2018 -0400 +++ b/src/looms/004-turtle-curves.lisp Sat Mar 17 17:36:34 2018 -0400 @@ -31,10 +31,10 @@ (coord x y))) :color *color*)))) -(defmethod perform-command (turtle (command (eql 'fl)) n) +(defmethod perform-command (turtle (command (eql 'l)) n) (perform-command turtle 'f n)) -(defmethod perform-command (turtle (command (eql 'fr)) n) +(defmethod perform-command (turtle (command (eql 'r)) n) (perform-command turtle 'f n)) (defmethod perform-command (turtle (command (eql 's)) n) @@ -83,21 +83,23 @@ (minimizing (y p2) :into min-y) (finally (return (list min-x min-y max-x max-y))))) -(defun scale (paths) +(defun scale (paths &optional (bottom-padding 0)) (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)) + (with x-padding = (+ (/ (- 1.0 (* factor (- max-x min-x))) 2) + (/ bottom-padding 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) %) + (y p1) (map-range min-y max-y y-padding (- 1.0 y-padding bottom-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) %)))) + (y p2) (map-range min-y max-y y-padding (- 1.0 y-padding bottom-padding) %))) + paths) (defun encode (commands) @@ -110,11 +112,22 @@ (setf n 1))))) (defun turtle-draw (commands) - (let ((paths (iterate (with turtle = (make-turtle)) - (for (command . n) :in (encode commands)) - (appending (perform-command turtle command n))))) - (scale paths) - paths)) + (iterate (with turtle = (make-turtle)) + (for (command . n) :in (encode commands)) + (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 ---------------------------------------------------------------- @@ -182,17 +195,17 @@ (define-l-system unnamed-koch-f (f - f - f - f) f (f - f + f - f - f)) -(define-l-system dragon-curve fl - fl (fl + fr +) - fr (- fl - fr)) +(define-l-system dragon-curve l + l (l + r +) + r (- l - r)) -(define-l-system (sierpinski-gasket :angle (/ tau 6)) fr - fl (fr + fl + fr) - fr (fl - fr - fl)) +(define-l-system (sierpinski-gasket :angle (/ tau 6)) r + l (r + l + r) + r (l - r - l)) -(define-l-system (hexagonal-gosper-curve :angle (/ tau 6)) fl - fl (fl + fr + + fr - fl - - fl fl - fr +) - fr (- fl + fr fr + + fr + fl - - fl - fr)) +(define-l-system (hexagonal-gosper-curve :angle (/ tau 6)) l + l (l + r + + r - l - - l l - r +) + r (- l + r r + + r + l - - l - r)) (define-l-system (tree-a :angle (radians 25.7)) f @@ -272,7 +285,7 @@ #'rand)) (defun loom (seed filename filetype width height - &optional l-system iterations starting-angle) + &key l-system iterations starting-angle render-productions) (nest (with-seed seed) (destructuring-bind @@ -291,6 +304,7 @@ (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 @@ -299,14 +313,26 @@ <>))) (*angle* (l-system-recommended-angle l-system)))) (flax.drawing:with-rendering - (canvas filetype filename width height :background bg)) + (canvas filetype filename width height + :background bg + :padding (if render-productions 0.015 0.05))) (progn (-<> (run-l-system axiom productions iterations) - (turtle-draw <>) + 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))))) -;; (time (loom 201354591 "out" :svg 1000 1000 -;; *tree-f* 6 (- 1/4tau))) +;; (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 +;; )) + diff -r 630bc79afdfd -r 29137fb2d208 src/looms/006-tracing-lines.lisp --- a/src/looms/006-tracing-lines.lisp Thu Mar 15 00:28:01 2018 -0400 +++ b/src/looms/006-tracing-lines.lisp Sat Mar 17 17:36:34 2018 -0400 @@ -1,7 +1,7 @@ (in-package :flax.looms.006-tracing-lines) ;;;; Config ------------------------------------------------------------------- -(defparameter *spread* 0.0020) +(defparameter *spread-y* 0.0020) ;;;; Convert ------------------------------------------------------------------ @@ -26,7 +26,7 @@ (make-array points :initial-element 0.0)) (defun perturb (point) - (random-around point *spread* #'rand)) + (random-around point *spread-y* #'rand)) (defun wrapping-aref (array i) (aref array (mod i (length array)))) @@ -41,7 +41,7 @@ (average (subseq line (max 0 (- i 2)) (min (1- (length line)) (+ i 1)))) - *spread* #'rand) + *spread-y* #'rand) :result-type 'vector))) (defun generate-lines (points lines) @@ -52,16 +52,18 @@ ;;;; Main --------------------------------------------------------------------- -(defun loom (seed filename filetype width height) +(defun loom (seed filename filetype width height &key lines points) (nest (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)) - (*spread* (/ 0.15 lines)))) + (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)))) (progn (flax.drawing:render canvas (convert-lines (generate-lines points lines))) (list points lines)))) -;; (time (loom nil "out" :svg 800 800)) +;; (time (loom nil "out" :svg 800 800 :lines 200 :points 100))