Add string rendering and the characters we need for l-systems
Changes
--- a/flax.asd Sun Jun 09 16:38:17 2019 -0400
+++ b/flax.asd Sun Jun 09 18:54:56 2019 -0400
@@ -33,7 +33,8 @@
(:file "colors")
(:file "transform")
(:module "drawing" :serial t
- :components ((:file "api")
+ :components ((:file "letters")
+ (:file "api")
(:file "png")
(:file "svg")
(:file "plot")))
--- a/src/drawing/api.lisp Sun Jun 09 16:38:17 2019 -0400
+++ b/src/drawing/api.lisp Sun Jun 09 18:54:56 2019 -0400
@@ -222,32 +222,97 @@
point)
+;;;; Glyph --------------------------------------------------------------------
+(defclass* glyph (drawable)
+ ((pos :type vec3)
+ (width :type single-float)
+ (ch :type character)
+ (paths :type list)))
+
+(defun glyph (position width character &key (opacity 1.0d0) (color *black*))
+ (make-instance 'glyph
+ :pos (homogenize position)
+ :width (coerce width 'single-float)
+ :ch character
+ :color color
+ :opacity (coerce opacity 'double-float)))
+
+(defun recompute-glyph-paths (glyph)
+ (let ((paths (letter-paths (ch glyph)))
+ (size (* 2 (width glyph))))
+ (ntransform paths (transformation
+ (scale size size)
+ (translate (vx (pos glyph))
+ (vy (pos glyph)))))
+ (setf (paths glyph) paths)))
+
+(defmethod initialize-instance :after ((glyph glyph) &key)
+ (recompute-glyph-paths glyph))
+
+(defmethod print-object ((o glyph) s)
+ (print-unreadable-object (o s :type t :identity nil)
+ (format s "~A ~A" (ch o) (pos o))))
+
+(defmethod ntransform ((glyph glyph) transformation)
+ (ntransform (pos glyph) transformation)
+ (ntransformf (width glyph) transformation)
+ (ntransformf (paths glyph) transformation)
+ ;; (recompute-glyph-paths glyph)
+ glyph)
+
+(defmethod draw (canvas (glyph glyph))
+ (map-curried #'draw canvas (paths glyph)))
+
+
;;;; Text ---------------------------------------------------------------------
(defclass* text (drawable)
((pos :type vec3)
- (font :type string)
- (size :type single-float)
- (align :type keyword)
- (content :type string)))
+ (letter-width :type single-float)
+ (letter-spacing :type single-float)
+ (content :type string)
+ (glyphs :type list)))
-(defun text (position size font content
- &key (opacity 1.0d0) (color *black*) (align :left))
+(defun rebuild-glyphs (text)
+ (setf (glyphs text)
+ (iterate
+ (with pos = (pos text))
+ (with y = (vy (pos text)))
+ (with space = (+ (letter-width text) (letter-spacing text)))
+ (with scale = (/ (letter-width text) 0.5))
+ (for ch :in-string (content text))
+ (for pch :previous ch)
+ (for x :from (vx pos) :by space)
+ (incf x (* (kern pch ch) scale))
+ (collect (glyph (vec x y) (letter-width text) ch
+ :opacity (opacity text)
+ :color (color text))))))
+
+(defun text (position letter-width content &key (letter-spacing 0.0) (opacity 1.0d0) (color *black*))
(make-instance 'text
- :pos (homogenize position) :size size :font font :content content
- :align align
+ :pos (homogenize position)
+ :letter-width (coerce letter-width 'single-float)
+ :letter-spacing (coerce letter-spacing 'single-float)
+ :content content
:color color
:opacity (coerce opacity 'double-float)))
+(defmethod initialize-instance :after ((text text) &key)
+ (rebuild-glyphs text))
+
+
(defmethod print-object ((o text) s)
(print-unreadable-object (o s :type t :identity nil)
- (format s "~S (~D, ~D)"
+ (format s "~S ~A"
(content o)
- (vx (pos o))
- (vy (pos o)))))
+ (pos o))))
+
+(defmethod draw (canvas (text text))
+ (map-curried #'draw canvas (glyphs text)))
(defmethod ntransform ((text text) transformation)
(ntransform (pos text) transformation)
- (zapf (size text) (ntransform % transformation))
+ (ntransformf (letter-width text) transformation)
+ (rebuild-glyphs text)
text)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/drawing/letters.lisp Sun Jun 09 18:54:56 2019 -0400
@@ -0,0 +1,106 @@
+(in-package :flax.drawing)
+
+(defgeneric letter-paths (character))
+
+(defmethod letter-paths ((character (eql #\Space)))
+ (list))
+
+(defmethod letter-paths ((character (eql #\+)))
+ ;; p₁
+ ;; |
+ ;; |
+ ;; p₃ ----+---- p₄
+ ;; |
+ ;; |
+ ;; p₂
+ (let ((p1 (vec 0.25 0.35))
+ (p2 (vec 0.25 0.75))
+ (p3 (vec 0.05 0.55))
+ (p4 (vec 0.45 0.55)))
+ (list (path (list p1 p2))
+ (path (list p3 p4)))))
+
+(defmethod letter-paths ((character (eql #\-)))
+ (let ((p1 (vec 0.05 0.55))
+ (p2 (vec 0.45 0.55)))
+ (list (path (list p1 p2)))))
+
+(defmethod letter-paths ((character (eql #\L)))
+ ;; p₁
+ ;; |
+ ;; |
+ ;; |
+ ;; |
+ ;; p₂|______ p₃
+ (let ((p1 (vec 0.05 0.10))
+ (p2 (vec 0.05 1.00))
+ (p3 (vec 0.45 1.00)))
+ (list (path (list p1 p2 p3)))))
+
+(defmethod letter-paths ((character (eql #\R)))
+ ;; p₁___ p₃
+ ;; | \
+ ;; p₆|___/ p₄
+ ;; | \
+ ;; | \
+ ;; p₂| \ p₅
+ (let ((p1 (vec 0.05 0.10))
+ (p2 (vec 0.05 1.00))
+ (p3 (vec 0.25 0.10))
+ (p4 (vec 0.25 0.55))
+ (p5 (vec 0.45 1.00))
+ (p6 (vec 0.05 0.55)))
+ (list (path (list p1 p2))
+ (path (list p1 p3
+ (list p4
+ (vec 0.45 0.10)
+ (vec 0.45 0.55))
+ p5))
+ (path (list p4 p6)))))
+
+(defmethod letter-paths ((character (eql #\→)))
+ (let ((p1 (vec 0.05 0.55))
+ (p2 (vec 0.45 0.55))
+ (p3 (vec 0.30 0.45))
+ (p4 (vec 0.30 0.65)))
+ (list (path (list p1 p2))
+ (path (list p3 p2 p4)))))
+
+(defmethod letter-paths ((character (eql #\()))
+ (let ((p1 (vec 0.40 0.10))
+ (p2 (vec 0.40 1.00)))
+ (list (path (list p1
+ (list p2
+ (vec 0.05 0.25)
+ (vec 0.05 0.85)))))))
+
+(defmethod letter-paths ((character (eql #\))))
+ (let ((p1 (vec 0.10 0.10))
+ (p2 (vec 0.10 1.00)))
+ (list (path (list p1
+ (list p2
+ (vec 0.45 0.25)
+ (vec 0.45 0.85)))))))
+
+
+(defgeneric kern (a b))
+
+(defmethod kern ((a character) (b character))
+ 0.0)
+
+(defmethod kern ((a null) b)
+ 0.0)
+
+(defmethod kern ((a (eql #\L)) (b (eql #\+))) -0.15)
+(defmethod kern ((a (eql #\L)) (b (eql #\-))) -0.15)
+(defmethod kern ((a (eql #\L)) (b (eql #\→))) -0.15)
+(defmethod kern ((a (eql #\L)) (b (eql #\())) -0.07)
+(defmethod kern ((a (eql #\R)) (b (eql #\→))) -0.05)
+(defmethod kern ((a (eql #\R)) (b (eql #\L))) 0.05)
+(defmethod kern ((a (eql #\→)) (b (eql #\L))) 0.05)
+(defmethod kern ((a (eql #\→)) (b (eql #\R))) 0.05)
+(defmethod kern ((a (eql #\()) (b (eql #\-))) -0.05)
+(defmethod kern ((a (eql #\()) (b (eql #\+))) -0.05)
+(defmethod kern ((a (eql #\-)) (b (eql #\)))) -0.05)
+(defmethod kern ((a (eql #\+)) (b (eql #\)))) -0.05)
+
--- a/src/drawing/svg.lisp Sun Jun 09 16:38:17 2019 -0400
+++ b/src/drawing/svg.lisp Sun Jun 09 18:54:56 2019 -0400
@@ -61,21 +61,6 @@
:fill-opacity (opacity p)))))
-;;;; 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 points-to-pairs (canvas points)
(loop :for ps :in points :collect (coords-to-pairs canvas ps)))
--- a/src/package.lisp Sun Jun 09 16:38:17 2019 -0400
+++ b/src/package.lisp Sun Jun 09 18:54:56 2019 -0400
@@ -29,7 +29,8 @@
:rotate
:place
:translate
- :ntransform))
+ :ntransform
+ :ntransformf))
(defpackage :flax.drawing
(:use :cl :iterate :losh :flax.base :flax.quickutils
@@ -47,7 +48,8 @@
:rectangle
:point
:circle
- :text))
+ :text
+ :glyph))
(defpackage :flax.looms.001-triangles
--- a/src/transform.lisp Sun Jun 09 16:38:17 2019 -0400
+++ b/src/transform.lisp Sun Jun 09 18:54:56 2019 -0400
@@ -59,3 +59,7 @@
(defmethod ntransform ((sequence sequence) transformation)
(map-into sequence (rcurry #'ntransform transformation) sequence))
+
+(defmacro ntransformf (place transformation)
+ ;; im lazy
+ `(setf ,place (ntransform ,place ,transformation)))