first commit

This commit is contained in:
Thorn Avery 2021-06-11 07:15:52 +00:00
commit edfb7bae16
5 changed files with 163 additions and 0 deletions

6
README.md Normal file
View File

@ -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

BIN
out.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 46 KiB

70
svg.rkt Normal file
View File

@ -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))

1
test.svg Normal file
View File

@ -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>

After

Width:  |  Height:  |  Size: 1.1 KiB

86
xml.rkt Normal file
View File

@ -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))