You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
81 lines
3.2 KiB
Racket
81 lines
3.2 KiB
Racket
#lang pitfall/racket
|
|
(require brag/support sugar/list)
|
|
(provide parse-svg-path)
|
|
|
|
(define (parse-svg-path doc path)
|
|
(define commands (parse path))
|
|
(apply-commands commands doc))
|
|
|
|
(define (parse path)
|
|
(define lex-1
|
|
(lexer
|
|
[(eof) eof]
|
|
[alphabetic (string->symbol lexeme)]
|
|
[(:: (:? "-") (:* numeric) (:? ".") (:+ numeric)) (string->number lexeme)]
|
|
[(:or whitespace ",") (lex-1 input-port)]))
|
|
(slicef-at (for/list ([tok (in-port lex-1 (open-input-string path))])
|
|
tok) symbol?))
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
(check-equal?
|
|
(parse "M 0,20 L 100,160 Q 130,200 150,120 C 190,-40 200,200 300,150 L 400,90")
|
|
'((M 0 20)
|
|
(L 100 160)
|
|
(Q 130 200 150 120)
|
|
(C 190 -40 200 200 300 150)
|
|
(L 400 90)))
|
|
|
|
(check-equal?
|
|
(parse "M-122.304 84.285C-122.304 84.285 -122.203 86.179 -123.027 86.16C-123.851 86.141 -140.305 38.066 -160.833 40.309C-160.833 40.309 -143.05 32.956 -122.304 84.285z")
|
|
'((M -122.304 84.285)
|
|
(C -122.304 84.285 -122.203 86.179 -123.027 86.16)
|
|
(C -123.851 86.141 -140.305 38.066 -160.833 40.309)
|
|
(C -160.833 40.309 -143.05 32.956 -122.304 84.285)
|
|
(z)))
|
|
|
|
(check-equal? (parse "L100-160") '((L 100 -160))))
|
|
|
|
(define (apply-commands commands doc)
|
|
(for/fold ([cx 0][cy 0][px 0][py 0][sx 0][sy 0])
|
|
([cmd (in-list commands)])
|
|
(match-define (cons cmd-name cmd-args) cmd)
|
|
(let loop ([cmd-name cmd-name][cmd-args cmd-args])
|
|
(match-define (list a0 a1 a2 a3 a4 a5)
|
|
(append cmd-args (make-list (- 6 (length cmd-args)) #f)))
|
|
(case cmd-name
|
|
[(M) (send doc moveTo . cmd-args)
|
|
(values a0 a1 #f #f a0 a1)]
|
|
[(m) (loop 'M (list (+ cx a0) (+ cy a1)))]
|
|
[(C) (send doc bezierCurveTo . cmd-args)
|
|
(values a4 a5 a2 a3 sx sy)]
|
|
[(c) (loop 'C (list (+ cx a0) (+ cy a1)
|
|
(+ cx a2) (+ cy a3)
|
|
(+ cx a4) (+ cy a5)))]
|
|
[(S) (match-let ([(list px py) (if (not px)
|
|
(list cx cy)
|
|
(list px py))])
|
|
(send doc bezierCurveyTo (- cx (- px cx)) (- cy (- py cy)) a0 a1 a2 a3)
|
|
(values a2 a3 a0 a1 sx sy))]
|
|
[(s) (loop 'S (list (+ cx a0) (+ cy a1)
|
|
(+ cx a2) (+ cy a3)))]
|
|
[(L) (send doc lineTo . cmd-args)
|
|
(values a0 a1 #f #f sx sy)]
|
|
[(l) (loop 'L (list (+ cx a0) (+ cy a1)))]
|
|
[(H) (loop 'L (list a0 cy))]
|
|
[(h) (loop 'L (list (+ cx a0) cy))]
|
|
[(V) (loop 'L (list cx a0))]
|
|
[(v) (loop 'L (list cx (+ cy a0)))]
|
|
[(Q) (send doc quadraticCurveTo . cmd-args)
|
|
(values a2 a3 a0 a1 sx sy)]
|
|
[(q) (loop 'Q (list (+ cx a0) (+ cy a1)
|
|
(+ cx a2) (+ cy a3)))]
|
|
[(T) (match-define (list px py)
|
|
(if (not px)
|
|
(list cx py)
|
|
(list (- cx (- px cx) (- cy (- py cy))))))
|
|
(send doc quadraticCurveTo . cmd-args)]
|
|
;; todo other path ops
|
|
[(z) (send doc closePath . cmd-args)
|
|
(values sx sy px py sx sy)]
|
|
[else (raise-argument-error 'apply-commands "valid command name" cmd-name)])))) |