first commit

README.md

@@ -0,0 +1,6 @@
+# racket svg macros
+
+simple macros to make generating svg's a little easier.
+
+`test.svg` is what the current script produces
+`out.png` is that `svg` passed through inkscape at 10x size

svg.rkt

@@ -0,0 +1,70 @@
+#lang racket
+
+(require "xml.rkt")
+
+(define-tag svg)
+(define-tag defs)
+(define-single-tag circle)
+(define-single-tag rect)
+(define-single-tag line)
+(define-single-tag use)
+(define-tag clipPath)
+
+(displayln
+  (let
+    ([doc-width 100]
+     [doc-height 100]
+     [stone-radius 5]
+     [black-colour "#222222"]
+     [white-colour "#DDDDDD"]
+     [stone-border 1]
+     [board-edge 2]
+     [board-colour "#F9D77D"]
+     [edge-colour "#000000"])
+    (svg
+      ([xmlns:xlink "http://www.w3.org/1999/xlink"]
+       [width doc-width]
+       [height doc-width])
+      (defs ()
+        (clipPath
+          ([id "board-clip"])
+          (rect
+            ([width doc-width]
+             [height doc-height])))
+        (circle
+          ([id "black-stone"]
+           [cx 0]
+           [cy 0]
+           [r  stone-radius]
+           [stroke-width stone-border]
+           [stroke white-colour]
+           [fill black-colour]))
+        (circle
+          ([id "white-stone"]
+           [cx 0]
+           [cy 0]
+           [r stone-radius]
+           [stroke-width stone-border]
+           [stroke black-colour]
+           [fill white-colour])))
+      (rect
+        ([width doc-width]
+         [height doc-height]
+         [stroke edge-colour]
+         [clip-path "url(#board-clip)"]
+         [stroke-width (* 2 board-edge)]
+         [fill board-colour]))
+      (map (lambda (x)
+             (use
+               ([xlink:href "#black-stone"]
+                [x (+ (/ doc-width 2)
+                      (* 30
+                         (cos (/ (* x pi)
+                                 180))))]
+                [y (+ (/ doc-height 2)
+                      (* 30
+                         (sin (/ (* x pi)
+                                 180))))])))
+           (range 0 360 40)))))
+
+(provide (all-defined-out))

test.svg

@@ -0,0 +1 @@
+<svg xmlns:xlink="http://www.w3.org/1999/xlink" width="100" height="100"><defs><clipPath id="board-clip"><rect width="100" height="100"/></clipPath><circle id="black-stone" cx="0" cy="0" r="5" stroke-width="1" stroke="#DDDDDD" fill="#222222"/><circle id="white-stone" cx="0" cy="0" r="5" stroke-width="1" stroke="#222222" fill="#DDDDDD"/></defs><rect width="100" height="100" stroke="#000000" clip-path="url(#board-clip)" stroke-width="4" fill="#F9D77D"/><use xlink:href="#black-stone" x="80" y="50"/><use xlink:href="#black-stone" x="72.98133329356934" y="69.28362829059617"/><use xlink:href="#black-stone" x="55.20944533000791" y="79.54423259036625"/><use xlink:href="#black-stone" x="35.00000000000001" y="75.98076211353316"/><use xlink:href="#black-stone" x="21.80922137642275" y="60.260604299770065"/><use xlink:href="#black-stone" x="21.809221376422748" y="39.73939570022994"/><use xlink:href="#black-stone" x="34.999999999999986" y="24.019237886466847"/><use xlink:href="#black-stone" x="55.209445330007895" y="20.455767409633758"/><use xlink:href="#black-stone" x="72.98133329356934" y="30.716371709403813"/></svg>

xml.rkt

@@ -0,0 +1,86 @@
+#lang racket
+
+(require
+  (for-syntax
+     racket/base
+     syntax/parse))
+
+(define (tag-start name attrs)
+  (string-append
+    (format "<~a" name)
+    (apply
+      string-append
+      (map (lambda (x)
+             (let ([t (car x)]
+                   [v (cdr x)])
+               (format " ~a=\"~a\"" t v)))
+           attrs))))
+
+(define (single-tag-end)
+  "/>")
+
+(define (tag-end name content)
+  (string-append
+    ">"
+    (if (list? content)
+      (apply string-append content)
+      content)
+    (format "</~a>" name)))
+
+(define (tag name attrs content)
+  (string-append
+    (tag-start name attrs)
+    (tag-end name content)))
+
+(define (single-tag name attrs)
+  (string-append
+    (tag-start name attrs)
+    (single-tag-end)))
+
+(define-syntax (mtag stx)
+  (syntax-parse stx
+    [(_ name:id
+        ([t:id v:expr] ...)
+        content:expr ...)
+     #'(tag
+         (symbol->string 'name)
+         (list
+           (cons
+             (symbol->string 't)
+             (if (number? v)
+                 (number->string v)
+                 v)) ...)
+         (apply string-append
+                (flatten
+                  (list content ...))))]))
+
+(define-syntax (msingle-tag stx)
+  (syntax-parse stx
+    [(_ name:id
+        ([t:id v:expr] ...))
+     #'(single-tag
+         (symbol->string 'name)
+         (list
+           (cons
+             (symbol->string 't)
+             (if (number? v)
+                 (number->string v)
+                 v)) ...))]))
+
+(define-syntax (define-tag stx)
+  (syntax-parse stx
+    [(_ name:id)
+     #'(define-syntax (name stx)
+         (syntax-parse stx
+           [(_ attrs:expr content:expr (... ...))
+            #'(mtag name attrs content (... ...))]))]))
+
+(define-syntax (define-single-tag stx)
+  (syntax-parse stx
+    [(_ name:id)
+     #'(define-syntax (name stx)
+         (syntax-parse stx
+           [(_ attrs:expr)
+            #'(msingle-tag name attrs)]))]))
+
+(provide (all-defined-out))