Add simple SVG helper procedures.

1 files changed, 61 insertions, 0 deletions

diff --git a/scales/svg.scm b/scales/svg.scm
new file mode 100644
index 0000000..f07034a
--- /dev/null
+++ b/scales/svg.scm
@@ -0,0 +1,61 @@
+(define-module (scales svg)
+  #:use-module (sxml simple)
+  #:export (line
+            circle
+            rectangle
+            text
+            svg
+
+            translate))
+
+(define* (line x1 y1 x2 y2
+               #:optional (style ""))
+  `(line (@ (x1 ,x1)
+            (y1 ,y1)
+            (x2 ,x2)
+            (y2 ,y2)
+            (style ,style))))
+
+(define* (circle x y radius
+                 #:optional (style ""))
+  `(circle (@ (cx ,x)
+              (cy ,y)
+              (r  ,radius)
+              (style ,style))))
+
+(define* (rectangle x y width height
+                    #:optional
+                    (rx 0)
+                    (ry 0)
+                    (style ""))
+  `(rect (@ (x ,x)
+            (y ,y)
+            (width  ,width)
+            (height ,height)
+            (rx ,rx)
+            (ry ,ry)
+            (style ,style))))
+
+(define* (text x y text
+               #:optional (style ""))
+  `(text (@ (x ,x)
+            (y ,y)
+            (style ,style))
+         ,text))
+
+(define* (svg exp
+              #:optional
+              (attributes
+               '((width 1200)
+                 (height 1200)
+                 (viewBox "0 0 1200 1200")
+                 (xmlns "http://www.w3.org/2000/svg"))))
+  (call-with-output-string
+    (lambda (port)
+      (sxml->xml `(svg (@ ,@attributes) ,exp) port))))
+
+(define (translate x y exp)
+  `(g (@ (transform ,(string-append "translate("
+                                    (number->string x) ","
+                                    (number->string y) ")")))
+      ,exp))